« back to all changes in this revision
Viewing changes to bin/pt-table-usage
- browse files at revision 3
- compare with another revision
- download diff
- download tarball
- view history from revision 3
- Committer: Daniel Nichter
- Date: 2011-06-24 22:02:05 UTC
- Revision ID: daniel@percona.com-20110624220205-e779cao9hcwyly1w
Add forked Maatkit tools in bin/ and their tests in t/.
- files added:
- bin/pt-archiver
- t/pt-archiver
- t/pt-archiver/samples
- t/pt-checksum-filter
- t/pt-config-diff
- t/pt-config-diff/samples
- t/pt-deadlock-logger
- t/pt-duplicate-key-checker
- t/pt-duplicate-key-checker/samples
- t/pt-fifo-split
- t/pt-fifo-split/samples
- t/pt-find
- t/pt-fk-error-logger
- t/pt-fk-error-logger/samples
- t/pt-heartbeat
- t/pt-heartbeat/samples
- t/pt-index-usage
- t/pt-index-usage/samples
- t/pt-kill
- t/pt-log-player
- t/pt-log-player/samples
- t/pt-log-player/samples/16sessions
- t/pt-online-schema-change
- t/pt-online-schema-change/samples
- t/pt-query-advisor
- t/pt-query-advisor/samples
- t/pt-query-digest
- t/pt-query-digest/samples
- t/pt-query-digest/samples/save-results
- t/pt-query-profiler
- t/pt-query-profiler/samples
- t/pt-show-grants
- t/pt-slave-delay
- t/pt-slave-find
- t/pt-slave-find/samples
- t/pt-slave-restart
- t/pt-table-checksum
- t/pt-table-checksum/samples
- t/pt-table-sync
- t/pt-table-sync/samples
- t/pt-table-sync/samples/bidirectional
- t/pt-table-usage
- t/pt-table-usage/samples
- t/pt-table-usage/samples/in
- t/pt-table-usage/samples/out
- t/pt-tcp-model
- t/pt-tcp-model/samples
- t/pt-tcp-model/samples/out
- t/pt-trend
- t/pt-upgrade
- t/pt-upgrade/samples
- t/pt-upgrade/samples/001
- t/pt-upgrade/samples/002
- t/pt-variable-advisor
- t/pt-variable-advisor/samples
- t/pt-visual-explain
- t/pt-visual-explain/samples
- files removed:
- t/lib/foo.t
added
removed
bin/pt-table-usage
1
#!/usr/bin/env perl
2
3
# This program is copyright 2009-@CURRENTYEAR@ Percona Inc.
4
# Feedback and improvements are welcome.
5
#
6
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
7
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
8
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
9
#
10
# This program is free software; you can redistribute it and/or modify it under
11
# the terms of the GNU General Public License as published by the Free Software
12
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
13
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
14
# licenses.
15
#
16
# You should have received a copy of the GNU General Public License along with
17
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
18
# Place, Suite 330, Boston, MA 02111-1307 USA.
19
20
use strict;
21
use warnings FATAL => 'all';
22
23
our $VERSION = '@VERSION@';
24
our $DISTRIB = '@DISTRIB@';
25
our $SVN_REV = sprintf("%d", (q$Revision: 7531 $ =~ m/(\d+)/g, 0));
26
27
# ###########################################################################
28
# DSNParser package 7388
29
# This package is a copy without comments from the original. The original
30
# with comments and its test file can be found in the SVN repository at,
31
# trunk/common/DSNParser.pm
32
# trunk/common/t/DSNParser.t
33
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
34
# ###########################################################################
35
36
package DSNParser;
37
38
use strict;
39
use warnings FATAL => 'all';
40
use English qw(-no_match_vars);
41
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
42
43
use Data::Dumper;
44
$Data::Dumper::Indent = 0;
45
$Data::Dumper::Quotekeys = 0;
46
47
eval {
48
require DBI;
49
};
50
my $have_dbi = $EVAL_ERROR ? 0 : 1;
51
52
53
sub new {
54
my ( $class, %args ) = @_;
55
foreach my $arg ( qw(opts) ) {
56
die "I need a $arg argument" unless $args{$arg};
57
}
58
my $self = {
59
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
60
};
61
foreach my $opt ( @{$args{opts}} ) {
62
if ( !$opt->{key} || !$opt->{desc} ) {
63
die "Invalid DSN option: ", Dumper($opt);
64
}
65
MKDEBUG && _d('DSN option:',
66
join(', ',
67
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
68
keys %$opt
69
)
70
);
71
$self->{opts}->{$opt->{key}} = {
72
dsn => $opt->{dsn},
73
desc => $opt->{desc},
74
copy => $opt->{copy} || 0,
75
};
76
}
77
return bless $self, $class;
78
}
79
80
sub prop {
81
my ( $self, $prop, $value ) = @_;
82
if ( @_ > 2 ) {
83
MKDEBUG && _d('Setting', $prop, 'property');
84
$self->{$prop} = $value;
85
}
86
return $self->{$prop};
87
}
88
89
sub parse {
90
my ( $self, $dsn, $prev, $defaults ) = @_;
91
if ( !$dsn ) {
92
MKDEBUG && _d('No DSN to parse');
93
return;
94
}
95
MKDEBUG && _d('Parsing', $dsn);
96
$prev ||= {};
97
$defaults ||= {};
98
my %given_props;
99
my %final_props;
100
my $opts = $self->{opts};
101
102
foreach my $dsn_part ( split(/,/, $dsn) ) {
103
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
104
$given_props{$prop_key} = $prop_val;
105
}
106
else {
107
MKDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
108
$given_props{h} = $dsn_part;
109
}
110
}
111
112
foreach my $key ( keys %$opts ) {
113
MKDEBUG && _d('Finding value for', $key);
114
$final_props{$key} = $given_props{$key};
115
if ( !defined $final_props{$key}
116
&& defined $prev->{$key} && $opts->{$key}->{copy} )
117
{
118
$final_props{$key} = $prev->{$key};
119
MKDEBUG && _d('Copying value for', $key, 'from previous DSN');
120
}
121
if ( !defined $final_props{$key} ) {
122
$final_props{$key} = $defaults->{$key};
123
MKDEBUG && _d('Copying value for', $key, 'from defaults');
124
}
125
}
126
127
foreach my $key ( keys %given_props ) {
128
die "Unknown DSN option '$key' in '$dsn'. For more details, "
129
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
130
. "for complete documentation."
131
unless exists $opts->{$key};
132
}
133
if ( (my $required = $self->prop('required')) ) {
134
foreach my $key ( keys %$required ) {
135
die "Missing required DSN option '$key' in '$dsn'. For more details, "
136
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
137
. "for complete documentation."
138
unless $final_props{$key};
139
}
140
}
141
142
return \%final_props;
143
}
144
145
sub parse_options {
146
my ( $self, $o ) = @_;
147
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
148
my $dsn_string
149
= join(',',
150
map { "$_=".$o->get($_); }
151
grep { $o->has($_) && $o->get($_) }
152
keys %{$self->{opts}}
153
);
154
MKDEBUG && _d('DSN string made from options:', $dsn_string);
155
return $self->parse($dsn_string);
156
}
157
158
sub as_string {
159
my ( $self, $dsn, $props ) = @_;
160
return $dsn unless ref $dsn;
161
my %allowed = $props ? map { $_=>1 } @$props : ();
162
return join(',',
163
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
164
grep { defined $dsn->{$_} && $self->{opts}->{$_} }
165
grep { !$props || $allowed{$_} }
166
sort keys %$dsn );
167
}
168
169
sub usage {
170
my ( $self ) = @_;
171
my $usage
172
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
173
. " KEY COPY MEANING\n"
174
. " === ==== =============================================\n";
175
my %opts = %{$self->{opts}};
176
foreach my $key ( sort keys %opts ) {
177
$usage .= " $key "
178
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
179
. ($opts{$key}->{desc} || '[No description]')
180
. "\n";
181
}
182
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
183
return $usage;
184
}
185
186
sub get_cxn_params {
187
my ( $self, $info ) = @_;
188
my $dsn;
189
my %opts = %{$self->{opts}};
190
my $driver = $self->prop('dbidriver') || '';
191
if ( $driver eq 'Pg' ) {
192
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
193
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
194
grep { defined $info->{$_} }
195
qw(h P));
196
}
197
else {
198
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
199
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
200
grep { defined $info->{$_} }
201
qw(F h P S A))
202
. ';mysql_read_default_group=client';
203
}
204
MKDEBUG && _d($dsn);
205
return ($dsn, $info->{u}, $info->{p});
206
}
207
208
sub fill_in_dsn {
209
my ( $self, $dbh, $dsn ) = @_;
210
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
211
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
212
$user =~ s/@.*//;
213
$dsn->{h} ||= $vars->{hostname}->{Value};
214
$dsn->{S} ||= $vars->{'socket'}->{Value};
215
$dsn->{P} ||= $vars->{port}->{Value};
216
$dsn->{u} ||= $user;
217
$dsn->{D} ||= $db;
218
}
219
220
sub get_dbh {
221
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
222
$opts ||= {};
223
my $defaults = {
224
AutoCommit => 0,
225
RaiseError => 1,
226
PrintError => 0,
227
ShowErrorStatement => 1,
228
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
229
};
230
@{$defaults}{ keys %$opts } = values %$opts;
231
232
if ( $opts->{mysql_use_result} ) {
233
$defaults->{mysql_use_result} = 1;
234
}
235
236
if ( !$have_dbi ) {
237
die "Cannot connect to MySQL because the Perl DBI module is not "
238
. "installed or not found. Run 'perl -MDBI' to see the directories "
239
. "that Perl searches for DBI. If DBI is not installed, try:\n"
240
. " Debian/Ubuntu apt-get install libdbi-perl\n"
241
. " RHEL/CentOS yum install perl-DBI\n"
242
. " OpenSolaris pgk install pkg:/SUNWpmdbi\n";
243
244
}
245
246
my $dbh;
247
my $tries = 2;
248
while ( !$dbh && $tries-- ) {
249
MKDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, ' {',
250
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ), '}');
251
252
eval {
253
$dbh = DBI->connect($cxn_string, $user, $pass, $defaults);
254
255
if ( $cxn_string =~ m/mysql/i ) {
256
my $sql;
257
258
$sql = 'SELECT @@SQL_MODE';
259
MKDEBUG && _d($dbh, $sql);
260
my ($sql_mode) = $dbh->selectrow_array($sql);
261
262
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
263
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
264
. ($sql_mode ? ",$sql_mode" : '')
265
. '\'*/';
266
MKDEBUG && _d($dbh, $sql);
267
$dbh->do($sql);
268
269
if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
270
$sql = "/*!40101 SET NAMES $charset*/";
271
MKDEBUG && _d($dbh, ':', $sql);
272
$dbh->do($sql);
273
MKDEBUG && _d('Enabling charset for STDOUT');
274
if ( $charset eq 'utf8' ) {
275
binmode(STDOUT, ':utf8')
276
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
277
}
278
else {
279
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
280
}
281
}
282
283
if ( $self->prop('set-vars') ) {
284
$sql = "SET " . $self->prop('set-vars');
285
MKDEBUG && _d($dbh, ':', $sql);
286
$dbh->do($sql);
287
}
288
}
289
};
290
if ( !$dbh && $EVAL_ERROR ) {
291
MKDEBUG && _d($EVAL_ERROR);
292
if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
293
MKDEBUG && _d('Going to try again without utf8 support');
294
delete $defaults->{mysql_enable_utf8};
295
}
296
elsif ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
297
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
298
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
299
. "the directories that Perl searches for DBD::mysql. If "
300
. "DBD::mysql is not installed, try:\n"
301
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
302
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
303
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
304
}
305
if ( !$tries ) {
306
die $EVAL_ERROR;
307
}
308
}
309
}
310
311
MKDEBUG && _d('DBH info: ',
312
$dbh,
313
Dumper($dbh->selectrow_hashref(
314
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
315
'Connection info:', $dbh->{mysql_hostinfo},
316
'Character set info:', Dumper($dbh->selectall_arrayref(
317
'SHOW VARIABLES LIKE "character_set%"', { Slice => {}})),
318
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
319
'$DBI::VERSION:', $DBI::VERSION,
320
);
321
322
return $dbh;
323
}
324
325
sub get_hostname {
326
my ( $self, $dbh ) = @_;
327
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
328
return $host;
329
}
330
my ( $hostname, $one ) = $dbh->selectrow_array(
331
'SELECT /*!50038 @@hostname, */ 1');
332
return $hostname;
333
}
334
335
sub disconnect {
336
my ( $self, $dbh ) = @_;
337
MKDEBUG && $self->print_active_handles($dbh);
338
$dbh->disconnect;
339
}
340
341
sub print_active_handles {
342
my ( $self, $thing, $level ) = @_;
343
$level ||= 0;
344
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
345
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
346
or die "Cannot print: $OS_ERROR";
347
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
348
$self->print_active_handles( $handle, $level + 1 );
349
}
350
}
351
352
sub copy {
353
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
354
die 'I need a dsn_1 argument' unless $dsn_1;
355
die 'I need a dsn_2 argument' unless $dsn_2;
356
my %new_dsn = map {
357
my $key = $_;
358
my $val;
359
if ( $args{overwrite} ) {
360
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
361
}
362
else {
363
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
364
}
365
$key => $val;
366
} keys %{$self->{opts}};
367
return \%new_dsn;
368
}
369
370
sub _d {
371
my ($package, undef, $line) = caller 0;
372
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
373
map { defined $_ ? $_ : 'undef' }
374
@_;
375
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
376
}
377
378
1;
379
380
# ###########################################################################
381
# End DSNParser package
382
# ###########################################################################
383
384
# ###########################################################################
385
# OptionParser package 7102
386
# This package is a copy without comments from the original. The original
387
# with comments and its test file can be found in the SVN repository at,
388
# trunk/common/OptionParser.pm
389
# trunk/common/t/OptionParser.t
390
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
391
# ###########################################################################
392
393
package OptionParser;
394
395
use strict;
396
use warnings FATAL => 'all';
397
use List::Util qw(max);
398
use English qw(-no_match_vars);
399
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
400
401
use Getopt::Long;
402
403
my $POD_link_re = '[LC]<"?([^">]+)"?>';
404
405
sub new {
406
my ( $class, %args ) = @_;
407
my @required_args = qw();
408
foreach my $arg ( @required_args ) {
409
die "I need a $arg argument" unless $args{$arg};
410
}
411
412
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
413
$program_name ||= $PROGRAM_NAME;
414
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
415
416
my %attributes = (
417
'type' => 1,
418
'short form' => 1,
419
'group' => 1,
420
'default' => 1,
421
'cumulative' => 1,
422
'negatable' => 1,
423
);
424
425
my $self = {
426
head1 => 'OPTIONS', # These args are used internally
427
skip_rules => 0, # to instantiate another Option-
428
item => '--(.*)', # Parser obj that parses the
429
attributes => \%attributes, # DSN OPTIONS section. Tools
430
parse_attributes => \&_parse_attribs, # don't tinker with these args.
431
432
%args,
433
434
strict => 1, # disabled by a special rule
435
program_name => $program_name,
436
opts => {},
437
got_opts => 0,
438
short_opts => {},
439
defaults => {},
440
groups => {},
441
allowed_groups => {},
442
errors => [],
443
rules => [], # desc of rules for --help
444
mutex => [], # rule: opts are mutually exclusive
445
atleast1 => [], # rule: at least one opt is required
446
disables => {}, # rule: opt disables other opts
447
defaults_to => {}, # rule: opt defaults to value of other opt
448
DSNParser => undef,
449
default_files => [
450
"/etc/maatkit/maatkit.conf",
451
"/etc/maatkit/$program_name.conf",
452
"$home/.maatkit.conf",
453
"$home/.$program_name.conf",
454
],
455
types => {
456
string => 's', # standard Getopt type
457
int => 'i', # standard Getopt type
458
float => 'f', # standard Getopt type
459
Hash => 'H', # hash, formed from a comma-separated list
460
hash => 'h', # hash as above, but only if a value is given
461
Array => 'A', # array, similar to Hash
462
array => 'a', # array, similar to hash
463
DSN => 'd', # DSN
464
size => 'z', # size with kMG suffix (powers of 2^10)
465
time => 'm', # time, with an optional suffix of s/h/m/d
466
},
467
};
468
469
return bless $self, $class;
470
}
471
472
sub get_specs {
473
my ( $self, $file ) = @_;
474
$file ||= $self->{file} || __FILE__;
475
my @specs = $self->_pod_to_specs($file);
476
$self->_parse_specs(@specs);
477
478
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
479
my $contents = do { local $/ = undef; <$fh> };
480
close $fh;
481
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
482
MKDEBUG && _d('Parsing DSN OPTIONS');
483
my $dsn_attribs = {
484
dsn => 1,
485
copy => 1,
486
};
487
my $parse_dsn_attribs = sub {
488
my ( $self, $option, $attribs ) = @_;
489
map {
490
my $val = $attribs->{$_};
491
if ( $val ) {
492
$val = $val eq 'yes' ? 1
493
: $val eq 'no' ? 0
494
: $val;
495
$attribs->{$_} = $val;
496
}
497
} keys %$attribs;
498
return {
499
key => $option,
500
%$attribs,
501
};
502
};
503
my $dsn_o = new OptionParser(
504
description => 'DSN OPTIONS',
505
head1 => 'DSN OPTIONS',
506
dsn => 0, # XXX don't infinitely recurse!
507
item => '\* (.)', # key opts are a single character
508
skip_rules => 1, # no rules before opts
509
attributes => $dsn_attribs,
510
parse_attributes => $parse_dsn_attribs,
511
);
512
my @dsn_opts = map {
513
my $opts = {
514
key => $_->{spec}->{key},
515
dsn => $_->{spec}->{dsn},
516
copy => $_->{spec}->{copy},
517
desc => $_->{desc},
518
};
519
$opts;
520
} $dsn_o->_pod_to_specs($file);
521
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
522
}
523
524
return;
525
}
526
527
sub DSNParser {
528
my ( $self ) = @_;
529
return $self->{DSNParser};
530
};
531
532
sub get_defaults_files {
533
my ( $self ) = @_;
534
return @{$self->{default_files}};
535
}
536
537
sub _pod_to_specs {
538
my ( $self, $file ) = @_;
539
$file ||= $self->{file} || __FILE__;
540
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
541
542
my @specs = ();
543
my @rules = ();
544
my $para;
545
546
local $INPUT_RECORD_SEPARATOR = '';
547
while ( $para = <$fh> ) {
548
next unless $para =~ m/^=head1 $self->{head1}/;
549
last;
550
}
551
552
while ( $para = <$fh> ) {
553
last if $para =~ m/^=over/;
554
next if $self->{skip_rules};
555
chomp $para;
556
$para =~ s/\s+/ /g;
557
$para =~ s/$POD_link_re/$1/go;
558
MKDEBUG && _d('Option rule:', $para);
559
push @rules, $para;
560
}
561
562
die "POD has no $self->{head1} section" unless $para;
563
564
do {
565
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
566
chomp $para;
567
MKDEBUG && _d($para);
568
my %attribs;
569
570
$para = <$fh>; # read next paragraph, possibly attributes
571
572
if ( $para =~ m/: / ) { # attributes
573
$para =~ s/\s+\Z//g;
574
%attribs = map {
575
my ( $attrib, $val) = split(/: /, $_);
576
die "Unrecognized attribute for --$option: $attrib"
577
unless $self->{attributes}->{$attrib};
578
($attrib, $val);
579
} split(/; /, $para);
580
if ( $attribs{'short form'} ) {
581
$attribs{'short form'} =~ s/-//;
582
}
583
$para = <$fh>; # read next paragraph, probably short help desc
584
}
585
else {
586
MKDEBUG && _d('Option has no attributes');
587
}
588
589
$para =~ s/\s+\Z//g;
590
$para =~ s/\s+/ /g;
591
$para =~ s/$POD_link_re/$1/go;
592
593
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
594
MKDEBUG && _d('Short help:', $para);
595
596
die "No description after option spec $option" if $para =~ m/^=item/;
597
598
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
599
$option = $base_option;
600
$attribs{'negatable'} = 1;
601
}
602
603
push @specs, {
604
spec => $self->{parse_attributes}->($self, $option, \%attribs),
605
desc => $para
606
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
607
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
608
};
609
}
610
while ( $para = <$fh> ) {
611
last unless $para;
612
if ( $para =~ m/^=head1/ ) {
613
$para = undef; # Can't 'last' out of a do {} block.
614
last;
615
}
616
last if $para =~ m/^=item /;
617
}
618
} while ( $para );
619
620
die "No valid specs in $self->{head1}" unless @specs;
621
622
close $fh;
623
return @specs, @rules;
624
}
625
626
sub _parse_specs {
627
my ( $self, @specs ) = @_;
628
my %disables; # special rule that requires deferred checking
629
630
foreach my $opt ( @specs ) {
631
if ( ref $opt ) { # It's an option spec, not a rule.
632
MKDEBUG && _d('Parsing opt spec:',
633
map { ($_, '=>', $opt->{$_}) } keys %$opt);
634
635
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
636
if ( !$long ) {
637
die "Cannot parse long option from spec $opt->{spec}";
638
}
639
$opt->{long} = $long;
640
641
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
642
$self->{opts}->{$long} = $opt;
643
644
if ( length $long == 1 ) {
645
MKDEBUG && _d('Long opt', $long, 'looks like short opt');
646
$self->{short_opts}->{$long} = $long;
647
}
648
649
if ( $short ) {
650
die "Duplicate short option -$short"
651
if exists $self->{short_opts}->{$short};
652
$self->{short_opts}->{$short} = $long;
653
$opt->{short} = $short;
654
}
655
else {
656
$opt->{short} = undef;
657
}
658
659
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
660
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
661
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
662
663
$opt->{group} ||= 'default';
664
$self->{groups}->{ $opt->{group} }->{$long} = 1;
665
666
$opt->{value} = undef;
667
$opt->{got} = 0;
668
669
my ( $type ) = $opt->{spec} =~ m/=(.)/;
670
$opt->{type} = $type;
671
MKDEBUG && _d($long, 'type:', $type);
672
673
674
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
675
676
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
677
$self->{defaults}->{$long} = defined $def ? $def : 1;
678
MKDEBUG && _d($long, 'default:', $def);
679
}
680
681
if ( $long eq 'config' ) {
682
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
683
}
684
685
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
686
$disables{$long} = $dis;
687
MKDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
688
}
689
690
$self->{opts}->{$long} = $opt;
691
}
692
else { # It's an option rule, not a spec.
693
MKDEBUG && _d('Parsing rule:', $opt);
694
push @{$self->{rules}}, $opt;
695
my @participants = $self->_get_participants($opt);
696
my $rule_ok = 0;
697
698
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
699
$rule_ok = 1;
700
push @{$self->{mutex}}, \@participants;
701
MKDEBUG && _d(@participants, 'are mutually exclusive');
702
}
703
if ( $opt =~ m/at least one|one and only one/ ) {
704
$rule_ok = 1;
705
push @{$self->{atleast1}}, \@participants;
706
MKDEBUG && _d(@participants, 'require at least one');
707
}
708
if ( $opt =~ m/default to/ ) {
709
$rule_ok = 1;
710
$self->{defaults_to}->{$participants[0]} = $participants[1];
711
MKDEBUG && _d($participants[0], 'defaults to', $participants[1]);
712
}
713
if ( $opt =~ m/restricted to option groups/ ) {
714
$rule_ok = 1;
715
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
716
my @groups = split(',', $groups);
717
%{$self->{allowed_groups}->{$participants[0]}} = map {
718
s/\s+//;
719
$_ => 1;
720
} @groups;
721
}
722
if( $opt =~ m/accepts additional command-line arguments/ ) {
723
$rule_ok = 1;
724
$self->{strict} = 0;
725
MKDEBUG && _d("Strict mode disabled by rule");
726
}
727
728
die "Unrecognized option rule: $opt" unless $rule_ok;
729
}
730
}
731
732
foreach my $long ( keys %disables ) {
733
my @participants = $self->_get_participants($disables{$long});
734
$self->{disables}->{$long} = \@participants;
735
MKDEBUG && _d('Option', $long, 'disables', @participants);
736
}
737
738
return;
739
}
740
741
sub _get_participants {
742
my ( $self, $str ) = @_;
743
my @participants;
744
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
745
die "Option --$long does not exist while processing rule $str"
746
unless exists $self->{opts}->{$long};
747
push @participants, $long;
748
}
749
MKDEBUG && _d('Participants for', $str, ':', @participants);
750
return @participants;
751
}
752
753
sub opts {
754
my ( $self ) = @_;
755
my %opts = %{$self->{opts}};
756
return %opts;
757
}
758
759
sub short_opts {
760
my ( $self ) = @_;
761
my %short_opts = %{$self->{short_opts}};
762
return %short_opts;
763
}
764
765
sub set_defaults {
766
my ( $self, %defaults ) = @_;
767
$self->{defaults} = {};
768
foreach my $long ( keys %defaults ) {
769
die "Cannot set default for nonexistent option $long"
770
unless exists $self->{opts}->{$long};
771
$self->{defaults}->{$long} = $defaults{$long};
772
MKDEBUG && _d('Default val for', $long, ':', $defaults{$long});
773
}
774
return;
775
}
776
777
sub get_defaults {
778
my ( $self ) = @_;
779
return $self->{defaults};
780
}
781
782
sub get_groups {
783
my ( $self ) = @_;
784
return $self->{groups};
785
}
786
787
sub _set_option {
788
my ( $self, $opt, $val ) = @_;
789
my $long = exists $self->{opts}->{$opt} ? $opt
790
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
791
: die "Getopt::Long gave a nonexistent option: $opt";
792
793
$opt = $self->{opts}->{$long};
794
if ( $opt->{is_cumulative} ) {
795
$opt->{value}++;
796
}
797
else {
798
$opt->{value} = $val;
799
}
800
$opt->{got} = 1;
801
MKDEBUG && _d('Got option', $long, '=', $val);
802
}
803
804
sub get_opts {
805
my ( $self ) = @_;
806
807
foreach my $long ( keys %{$self->{opts}} ) {
808
$self->{opts}->{$long}->{got} = 0;
809
$self->{opts}->{$long}->{value}
810
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
811
: $self->{opts}->{$long}->{is_cumulative} ? 0
812
: undef;
813
}
814
$self->{got_opts} = 0;
815
816
$self->{errors} = [];
817
818
if ( @ARGV && $ARGV[0] eq "--config" ) {
819
shift @ARGV;
820
$self->_set_option('config', shift @ARGV);
821
}
822
if ( $self->has('config') ) {
823
my @extra_args;
824
foreach my $filename ( split(',', $self->get('config')) ) {
825
eval {
826
push @extra_args, $self->_read_config_file($filename);
827
};
828
if ( $EVAL_ERROR ) {
829
if ( $self->got('config') ) {
830
die $EVAL_ERROR;
831
}
832
elsif ( MKDEBUG ) {
833
_d($EVAL_ERROR);
834
}
835
}
836
}
837
unshift @ARGV, @extra_args;
838
}
839
840
Getopt::Long::Configure('no_ignore_case', 'bundling');
841
GetOptions(
842
map { $_->{spec} => sub { $self->_set_option(@_); } }
843
grep { $_->{long} ne 'config' } # --config is handled specially above.
844
values %{$self->{opts}}
845
) or $self->save_error('Error parsing options');
846
847
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
848
printf("%s Ver %s Distrib %s Changeset %s\n",
849
$self->{program_name}, $main::VERSION, $main::DISTRIB, $main::SVN_REV)
850
or die "Cannot print: $OS_ERROR";
851
exit 0;
852
}
853
854
if ( @ARGV && $self->{strict} ) {
855
$self->save_error("Unrecognized command-line options @ARGV");
856
}
857
858
foreach my $mutex ( @{$self->{mutex}} ) {
859
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
860
if ( @set > 1 ) {
861
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
862
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
863
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
864
. ' are mutually exclusive.';
865
$self->save_error($err);
866
}
867
}
868
869
foreach my $required ( @{$self->{atleast1}} ) {
870
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
871
if ( @set == 0 ) {
872
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
873
@{$required}[ 0 .. scalar(@$required) - 2] )
874
.' or --'.$self->{opts}->{$required->[-1]}->{long};
875
$self->save_error("Specify at least one of $err");
876
}
877
}
878
879
$self->_check_opts( keys %{$self->{opts}} );
880
$self->{got_opts} = 1;
881
return;
882
}
883
884
sub _check_opts {
885
my ( $self, @long ) = @_;
886
my $long_last = scalar @long;
887
while ( @long ) {
888
foreach my $i ( 0..$#long ) {
889
my $long = $long[$i];
890
next unless $long;
891
my $opt = $self->{opts}->{$long};
892
if ( $opt->{got} ) {
893
if ( exists $self->{disables}->{$long} ) {
894
my @disable_opts = @{$self->{disables}->{$long}};
895
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
896
MKDEBUG && _d('Unset options', @disable_opts,
897
'because', $long,'disables them');
898
}
899
900
if ( exists $self->{allowed_groups}->{$long} ) {
901
902
my @restricted_groups = grep {
903
!exists $self->{allowed_groups}->{$long}->{$_}
904
} keys %{$self->{groups}};
905
906
my @restricted_opts;
907
foreach my $restricted_group ( @restricted_groups ) {
908
RESTRICTED_OPT:
909
foreach my $restricted_opt (
910
keys %{$self->{groups}->{$restricted_group}} )
911
{
912
next RESTRICTED_OPT if $restricted_opt eq $long;
913
push @restricted_opts, $restricted_opt
914
if $self->{opts}->{$restricted_opt}->{got};
915
}
916
}
917
918
if ( @restricted_opts ) {
919
my $err;
920
if ( @restricted_opts == 1 ) {
921
$err = "--$restricted_opts[0]";
922
}
923
else {
924
$err = join(', ',
925
map { "--$self->{opts}->{$_}->{long}" }
926
grep { $_ }
927
@restricted_opts[0..scalar(@restricted_opts) - 2]
928
)
929
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
930
}
931
$self->save_error("--$long is not allowed with $err");
932
}
933
}
934
935
}
936
elsif ( $opt->{is_required} ) {
937
$self->save_error("Required option --$long must be specified");
938
}
939
940
$self->_validate_type($opt);
941
if ( $opt->{parsed} ) {
942
delete $long[$i];
943
}
944
else {
945
MKDEBUG && _d('Temporarily failed to parse', $long);
946
}
947
}
948
949
die "Failed to parse options, possibly due to circular dependencies"
950
if @long == $long_last;
951
$long_last = @long;
952
}
953
954
return;
955
}
956
957
sub _validate_type {
958
my ( $self, $opt ) = @_;
959
return unless $opt;
960
961
if ( !$opt->{type} ) {
962
$opt->{parsed} = 1;
963
return;
964
}
965
966
my $val = $opt->{value};
967
968
if ( $val && $opt->{type} eq 'm' ) { # type time
969
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
970
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
971
if ( !$suffix ) {
972
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
973
$suffix = $s || 's';
974
MKDEBUG && _d('No suffix given; using', $suffix, 'for',
975
$opt->{long}, '(value:', $val, ')');
976
}
977
if ( $suffix =~ m/[smhd]/ ) {
978
$val = $suffix eq 's' ? $num # Seconds
979
: $suffix eq 'm' ? $num * 60 # Minutes
980
: $suffix eq 'h' ? $num * 3600 # Hours
981
: $num * 86400; # Days
982
$opt->{value} = ($prefix || '') . $val;
983
MKDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
984
}
985
else {
986
$self->save_error("Invalid time suffix for --$opt->{long}");
987
}
988
}
989
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
990
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
991
my $prev = {};
992
my $from_key = $self->{defaults_to}->{ $opt->{long} };
993
if ( $from_key ) {
994
MKDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
995
if ( $self->{opts}->{$from_key}->{parsed} ) {
996
$prev = $self->{opts}->{$from_key}->{value};
997
}
998
else {
999
MKDEBUG && _d('Cannot parse', $opt->{long}, 'until',
1000
$from_key, 'parsed');
1001
return;
1002
}
1003
}
1004
my $defaults = $self->{DSNParser}->parse_options($self);
1005
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
1006
}
1007
elsif ( $val && $opt->{type} eq 'z' ) { # type size
1008
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
1009
$self->_parse_size($opt, $val);
1010
}
1011
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
1012
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
1013
}
1014
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
1015
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
1016
}
1017
else {
1018
MKDEBUG && _d('Nothing to validate for option',
1019
$opt->{long}, 'type', $opt->{type}, 'value', $val);
1020
}
1021
1022
$opt->{parsed} = 1;
1023
return;
1024
}
1025
1026
sub get {
1027
my ( $self, $opt ) = @_;
1028
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1029
die "Option $opt does not exist"
1030
unless $long && exists $self->{opts}->{$long};
1031
return $self->{opts}->{$long}->{value};
1032
}
1033
1034
sub got {
1035
my ( $self, $opt ) = @_;
1036
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1037
die "Option $opt does not exist"
1038
unless $long && exists $self->{opts}->{$long};
1039
return $self->{opts}->{$long}->{got};
1040
}
1041
1042
sub has {
1043
my ( $self, $opt ) = @_;
1044
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1045
return defined $long ? exists $self->{opts}->{$long} : 0;
1046
}
1047
1048
sub set {
1049
my ( $self, $opt, $val ) = @_;
1050
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1051
die "Option $opt does not exist"
1052
unless $long && exists $self->{opts}->{$long};
1053
$self->{opts}->{$long}->{value} = $val;
1054
return;
1055
}
1056
1057
sub save_error {
1058
my ( $self, $error ) = @_;
1059
push @{$self->{errors}}, $error;
1060
return;
1061
}
1062
1063
sub errors {
1064
my ( $self ) = @_;
1065
return $self->{errors};
1066
}
1067
1068
sub usage {
1069
my ( $self ) = @_;
1070
warn "No usage string is set" unless $self->{usage}; # XXX
1071
return "Usage: " . ($self->{usage} || '') . "\n";
1072
}
1073
1074
sub descr {
1075
my ( $self ) = @_;
1076
warn "No description string is set" unless $self->{description}; # XXX
1077
my $descr = ($self->{description} || $self->{program_name} || '')
1078
. " For more details, please use the --help option, "
1079
. "or try 'perldoc $PROGRAM_NAME' "
1080
. "for complete documentation.";
1081
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
1082
unless $ENV{DONT_BREAK_LINES};
1083
$descr =~ s/ +$//mg;
1084
return $descr;
1085
}
1086
1087
sub usage_or_errors {
1088
my ( $self, $file, $return ) = @_;
1089
$file ||= $self->{file} || __FILE__;
1090
1091
if ( !$self->{description} || !$self->{usage} ) {
1092
MKDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
1093
my %synop = $self->_parse_synopsis($file);
1094
$self->{description} ||= $synop{description};
1095
$self->{usage} ||= $synop{usage};
1096
MKDEBUG && _d("Description:", $self->{description},
1097
"\nUsage:", $self->{usage});
1098
}
1099
1100
if ( $self->{opts}->{help}->{got} ) {
1101
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
1102
exit 0 unless $return;
1103
}
1104
elsif ( scalar @{$self->{errors}} ) {
1105
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
1106
exit 0 unless $return;
1107
}
1108
1109
return;
1110
}
1111
1112
sub print_errors {
1113
my ( $self ) = @_;
1114
my $usage = $self->usage() . "\n";
1115
if ( (my @errors = @{$self->{errors}}) ) {
1116
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
1117
. "\n";
1118
}
1119
return $usage . "\n" . $self->descr();
1120
}
1121
1122
sub print_usage {
1123
my ( $self ) = @_;
1124
die "Run get_opts() before print_usage()" unless $self->{got_opts};
1125
my @opts = values %{$self->{opts}};
1126
1127
my $maxl = max(
1128
map {
1129
length($_->{long}) # option long name
1130
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
1131
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
1132
}
1133
@opts);
1134
1135
my $maxs = max(0,
1136
map {
1137
length($_)
1138
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
1139
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
1140
}
1141
values %{$self->{short_opts}});
1142
1143
my $lcol = max($maxl, ($maxs + 3));
1144
my $rcol = 80 - $lcol - 6;
1145
my $rpad = ' ' x ( 80 - $rcol );
1146
1147
$maxs = max($lcol - 3, $maxs);
1148
1149
my $usage = $self->descr() . "\n" . $self->usage();
1150
1151
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
1152
push @groups, 'default';
1153
1154
foreach my $group ( reverse @groups ) {
1155
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
1156
foreach my $opt (
1157
sort { $a->{long} cmp $b->{long} }
1158
grep { $_->{group} eq $group }
1159
@opts )
1160
{
1161
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
1162
my $short = $opt->{short};
1163
my $desc = $opt->{desc};
1164
1165
$long .= $opt->{type} ? "=$opt->{type}" : "";
1166
1167
if ( $opt->{type} && $opt->{type} eq 'm' ) {
1168
my ($s) = $desc =~ m/\(suffix (.)\)/;
1169
$s ||= 's';
1170
$desc =~ s/\s+\(suffix .\)//;
1171
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
1172
. "d=days; if no suffix, $s is used.";
1173
}
1174
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol})(?:\s+|$)/g);
1175
$desc =~ s/ +$//mg;
1176
if ( $short ) {
1177
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
1178
}
1179
else {
1180
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
1181
}
1182
}
1183
}
1184
1185
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
1186
1187
if ( (my @rules = @{$self->{rules}}) ) {
1188
$usage .= "\nRules:\n\n";
1189
$usage .= join("\n", map { " $_" } @rules) . "\n";
1190
}
1191
if ( $self->{DSNParser} ) {
1192
$usage .= "\n" . $self->{DSNParser}->usage();
1193
}
1194
$usage .= "\nOptions and values after processing arguments:\n\n";
1195
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
1196
my $val = $opt->{value};
1197
my $type = $opt->{type} || '';
1198
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
1199
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
1200
: !defined $val ? '(No value)'
1201
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
1202
: $type =~ m/H|h/ ? join(',', sort keys %$val)
1203
: $type =~ m/A|a/ ? join(',', @$val)
1204
: $val;
1205
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
1206
}
1207
return $usage;
1208
}
1209
1210
sub prompt_noecho {
1211
shift @_ if ref $_[0] eq __PACKAGE__;
1212
my ( $prompt ) = @_;
1213
local $OUTPUT_AUTOFLUSH = 1;
1214
print $prompt
1215
or die "Cannot print: $OS_ERROR";
1216
my $response;
1217
eval {
1218
require Term::ReadKey;
1219
Term::ReadKey::ReadMode('noecho');
1220
chomp($response = <STDIN>);
1221
Term::ReadKey::ReadMode('normal');
1222
print "\n"
1223
or die "Cannot print: $OS_ERROR";
1224
};
1225
if ( $EVAL_ERROR ) {
1226
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
1227
}
1228
return $response;
1229
}
1230
1231
if ( MKDEBUG ) {
1232
print '# ', $^X, ' ', $], "\n";
1233
my $uname = `uname -a`;
1234
if ( $uname ) {
1235
$uname =~ s/\s+/ /g;
1236
print "# $uname\n";
1237
}
1238
printf("# %s Ver %s Distrib %s Changeset %s line %d\n",
1239
$PROGRAM_NAME, ($main::VERSION || ''), ($main::DISTRIB || ''),
1240
($main::SVN_REV || ''), __LINE__);
1241
print('# Arguments: ',
1242
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n");
1243
}
1244
1245
sub _read_config_file {
1246
my ( $self, $filename ) = @_;
1247
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
1248
my @args;
1249
my $prefix = '--';
1250
my $parse = 1;
1251
1252
LINE:
1253
while ( my $line = <$fh> ) {
1254
chomp $line;
1255
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
1256
$line =~ s/\s+#.*$//g;
1257
$line =~ s/^\s+|\s+$//g;
1258
if ( $line eq '--' ) {
1259
$prefix = '';
1260
$parse = 0;
1261
next LINE;
1262
}
1263
if ( $parse
1264
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
1265
) {
1266
push @args, grep { defined $_ } ("$prefix$opt", $arg);
1267
}
1268
elsif ( $line =~ m/./ ) {
1269
push @args, $line;
1270
}
1271
else {
1272
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
1273
}
1274
}
1275
close $fh;
1276
return @args;
1277
}
1278
1279
sub read_para_after {
1280
my ( $self, $file, $regex ) = @_;
1281
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
1282
local $INPUT_RECORD_SEPARATOR = '';
1283
my $para;
1284
while ( $para = <$fh> ) {
1285
next unless $para =~ m/^=pod$/m;
1286
last;
1287
}
1288
while ( $para = <$fh> ) {
1289
next unless $para =~ m/$regex/;
1290
last;
1291
}
1292
$para = <$fh>;
1293
chomp($para);
1294
close $fh or die "Can't close $file: $OS_ERROR";
1295
return $para;
1296
}
1297
1298
sub clone {
1299
my ( $self ) = @_;
1300
1301
my %clone = map {
1302
my $hashref = $self->{$_};
1303
my $val_copy = {};
1304
foreach my $key ( keys %$hashref ) {
1305
my $ref = ref $hashref->{$key};
1306
$val_copy->{$key} = !$ref ? $hashref->{$key}
1307
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
1308
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
1309
: $hashref->{$key};
1310
}
1311
$_ => $val_copy;
1312
} qw(opts short_opts defaults);
1313
1314
foreach my $scalar ( qw(got_opts) ) {
1315
$clone{$scalar} = $self->{$scalar};
1316
}
1317
1318
return bless \%clone;
1319
}
1320
1321
sub _parse_size {
1322
my ( $self, $opt, $val ) = @_;
1323
1324
if ( lc($val || '') eq 'null' ) {
1325
MKDEBUG && _d('NULL size for', $opt->{long});
1326
$opt->{value} = 'null';
1327
return;
1328
}
1329
1330
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
1331
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
1332
if ( defined $num ) {
1333
if ( $factor ) {
1334
$num *= $factor_for{$factor};
1335
MKDEBUG && _d('Setting option', $opt->{y},
1336
'to num', $num, '* factor', $factor);
1337
}
1338
$opt->{value} = ($pre || '') . $num;
1339
}
1340
else {
1341
$self->save_error("Invalid size for --$opt->{long}");
1342
}
1343
return;
1344
}
1345
1346
sub _parse_attribs {
1347
my ( $self, $option, $attribs ) = @_;
1348
my $types = $self->{types};
1349
return $option
1350
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
1351
. ($attribs->{'negatable'} ? '!' : '' )
1352
. ($attribs->{'cumulative'} ? '+' : '' )
1353
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
1354
}
1355
1356
sub _parse_synopsis {
1357
my ( $self, $file ) = @_;
1358
$file ||= $self->{file} || __FILE__;
1359
MKDEBUG && _d("Parsing SYNOPSIS in", $file);
1360
1361
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
1362
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
1363
my $para;
1364
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
1365
die "$file does not contain a SYNOPSIS section" unless $para;
1366
my @synop;
1367
for ( 1..2 ) { # 1 for the usage, 2 for the description
1368
my $para = <$fh>;
1369
push @synop, $para;
1370
}
1371
close $fh;
1372
MKDEBUG && _d("Raw SYNOPSIS text:", @synop);
1373
my ($usage, $desc) = @synop;
1374
die "The SYNOPSIS section in $file is not formatted properly"
1375
unless $usage && $desc;
1376
1377
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
1378
chomp $usage;
1379
1380
$desc =~ s/\n/ /g;
1381
$desc =~ s/\s{2,}/ /g;
1382
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
1383
$desc =~ s/\s+$//;
1384
1385
return (
1386
description => $desc,
1387
usage => $usage,
1388
);
1389
};
1390
1391
sub _d {
1392
my ($package, undef, $line) = caller 0;
1393
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1394
map { defined $_ ? $_ : 'undef' }
1395
@_;
1396
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1397
}
1398
1399
1;
1400
1401
# ###########################################################################
1402
# End OptionParser package
1403
# ###########################################################################
1404
1405
# ###########################################################################
1406
# SlowLogParser package 7522
1407
# This package is a copy without comments from the original. The original
1408
# with comments and its test file can be found in the SVN repository at,
1409
# trunk/common/SlowLogParser.pm
1410
# trunk/common/t/SlowLogParser.t
1411
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
1412
# ###########################################################################
1413
package SlowLogParser;
1414
1415
use strict;
1416
use warnings FATAL => 'all';
1417
use English qw(-no_match_vars);
1418
use Data::Dumper;
1419
1420
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
1421
1422
sub new {
1423
my ( $class ) = @_;
1424
my $self = {
1425
pending => [],
1426
};
1427
return bless $self, $class;
1428
}
1429
1430
my $slow_log_ts_line = qr/^# Time: ([0-9: ]{15})/;
1431
my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]/;
1432
my $slow_log_hd_line = qr{
1433
^(?:
1434
T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix
1435
|
1436
[/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary)
1437
|
1438
Time\s+Id\s+Command
1439
).*\n
1440
}xm;
1441
1442
sub parse_event {
1443
my ( $self, %args ) = @_;
1444
my @required_args = qw(next_event tell);
1445
foreach my $arg ( @required_args ) {
1446
die "I need a $arg argument" unless $args{$arg};
1447
}
1448
my ($next_event, $tell) = @args{@required_args};
1449
1450
my $pending = $self->{pending};
1451
local $INPUT_RECORD_SEPARATOR = ";\n#";
1452
my $trimlen = length($INPUT_RECORD_SEPARATOR);
1453
my $pos_in_log = $tell->();
1454
my $stmt;
1455
1456
EVENT:
1457
while (
1458
defined($stmt = shift @$pending)
1459
or defined($stmt = $next_event->())
1460
) {
1461
my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log);
1462
$pos_in_log = $tell->();
1463
1464
if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log
1465
my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt);
1466
if ( @chunks > 1 ) {
1467
MKDEBUG && _d("Found multiple chunks");
1468
$stmt = shift @chunks;
1469
unshift @$pending, @chunks;
1470
}
1471
}
1472
1473
$stmt = '#' . $stmt unless $stmt =~ m/\A#/;
1474
$stmt =~ s/;\n#?\Z//;
1475
1476
1477
my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed);
1478
my $pos = 0;
1479
my $len = length($stmt);
1480
my $found_arg = 0;
1481
LINE:
1482
while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match.
1483
$pos = pos($stmt); # Be careful not to mess this up!
1484
my $line = $1; # Necessary for /g and pos() to work.
1485
MKDEBUG && _d($line);
1486
1487
if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) {
1488
1489
if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) {
1490
MKDEBUG && _d("Got ts", $time);
1491
push @properties, 'ts', $time;
1492
++$got_ts;
1493
if ( !$got_uh
1494
&& ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
1495
) {
1496
MKDEBUG && _d("Got user, host, ip", $user, $host, $ip);
1497
push @properties, 'user', $user, 'host', $host, 'ip', $ip;
1498
++$got_uh;
1499
}
1500
}
1501
1502
elsif ( !$got_uh
1503
&& ( my ( $user, $host, $ip ) = $line =~ m/$slow_log_uh_line/o )
1504
) {
1505
MKDEBUG && _d("Got user, host, ip", $user, $host, $ip);
1506
push @properties, 'user', $user, 'host', $host, 'ip', $ip;
1507
++$got_uh;
1508
}
1509
1510
elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) {
1511
MKDEBUG && _d("Got admin command");
1512
$line =~ s/^#\s+//; # string leading "# ".
1513
push @properties, 'cmd', 'Admin', 'arg', $line;
1514
push @properties, 'bytes', length($properties[-1]);
1515
++$found_arg;
1516
++$got_ac;
1517
}
1518
1519
elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap!
1520
MKDEBUG && _d("Got some line with properties");
1521
1522
if ( $line =~ m/Schema:\s+\w+: / ) {
1523
MKDEBUG && _d('Removing empty Schema attrib');
1524
$line =~ s/Schema:\s+//;
1525
MKDEBUG && _d($line);
1526
}
1527
1528
my @temp = $line =~ m/(\w+):\s+(\S+|\Z)/g;
1529
push @properties, @temp;
1530
}
1531
1532
elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) {
1533
MKDEBUG && _d("Got a default database:", $db);
1534
push @properties, 'db', $db;
1535
++$got_db;
1536
}
1537
1538
elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) {
1539
MKDEBUG && _d("Got some setting:", $setting);
1540
push @properties, split(/,|\s*=\s*/, $setting);
1541
++$got_set;
1542
}
1543
1544
if ( !$found_arg && $pos == $len ) {
1545
MKDEBUG && _d("Did not find arg, looking for special cases");
1546
local $INPUT_RECORD_SEPARATOR = ";\n";
1547
if ( defined(my $l = $next_event->()) ) {
1548
chomp $l;
1549
$l =~ s/^\s+//;
1550
MKDEBUG && _d("Found admin statement", $l);
1551
push @properties, 'cmd', 'Admin', 'arg', $l;
1552
push @properties, 'bytes', length($properties[-1]);
1553
$found_arg++;
1554
}
1555
else {
1556
MKDEBUG && _d("I can't figure out what to do with this line");
1557
next EVENT;
1558
}
1559
}
1560
}
1561
else {
1562
MKDEBUG && _d("Got the query/arg line");
1563
my $arg = substr($stmt, $pos - length($line));
1564
push @properties, 'arg', $arg, 'bytes', length($arg);
1565
if ( $args{misc} && $args{misc}->{embed}
1566
&& ( my ($e) = $arg =~ m/($args{misc}->{embed})/)
1567
) {
1568
push @properties, $e =~ m/$args{misc}->{capture}/g;
1569
}
1570
last LINE;
1571
}
1572
}
1573
1574
MKDEBUG && _d('Properties of event:', Dumper(\@properties));
1575
my $event = { @properties };
1576
if ( $args{stats} ) {
1577
$args{stats}->{events_read}++;
1578
$args{stats}->{events_parsed}++;
1579
}
1580
return $event;
1581
} # EVENT
1582
1583
@$pending = ();
1584
$args{oktorun}->(0) if $args{oktorun};
1585
return;
1586
}
1587
1588
sub _d {
1589
my ($package, undef, $line) = caller 0;
1590
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1591
map { defined $_ ? $_ : 'undef' }
1592
@_;
1593
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1594
}
1595
1596
1;
1597
1598
# ###########################################################################
1599
# End SlowLogParser package
1600
# ###########################################################################
1601
1602
# ###########################################################################
1603
# Transformers package 7226
1604
# This package is a copy without comments from the original. The original
1605
# with comments and its test file can be found in the SVN repository at,
1606
# trunk/common/Transformers.pm
1607
# trunk/common/t/Transformers.t
1608
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
1609
# ###########################################################################
1610
1611
package Transformers;
1612
1613
use strict;
1614
use warnings FATAL => 'all';
1615
use English qw(-no_match_vars);
1616
use Time::Local qw(timegm timelocal);
1617
use Digest::MD5 qw(md5_hex);
1618
1619
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
1620
1621
require Exporter;
1622
our @ISA = qw(Exporter);
1623
our %EXPORT_TAGS = ();
1624
our @EXPORT = ();
1625
our @EXPORT_OK = qw(
1626
micro_t
1627
percentage_of
1628
secs_to_time
1629
time_to_secs
1630
shorten
1631
ts
1632
parse_timestamp
1633
unix_timestamp
1634
any_unix_timestamp
1635
make_checksum
1636
crc32
1637
);
1638
1639
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
1640
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
1641
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
1642
1643
sub micro_t {
1644
my ( $t, %args ) = @_;
1645
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
1646
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
1647
my $f;
1648
1649
$t = 0 if $t < 0;
1650
1651
$t = sprintf('%.17f', $t) if $t =~ /e/;
1652
1653
$t =~ s/\.(\d{1,6})\d*/\.$1/;
1654
1655
if ($t > 0 && $t <= 0.000999) {
1656
$f = ($t * 1000000) . 'us';
1657
}
1658
elsif ($t >= 0.001000 && $t <= 0.999999) {
1659
$f = sprintf("%.${p_ms}f", $t * 1000);
1660
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
1661
}
1662
elsif ($t >= 1) {
1663
$f = sprintf("%.${p_s}f", $t);
1664
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
1665
}
1666
else {
1667
$f = 0; # $t should = 0 at this point
1668
}
1669
1670
return $f;
1671
}
1672
1673
sub percentage_of {
1674
my ( $is, $of, %args ) = @_;
1675
my $p = $args{p} || 0; # float precision
1676
my $fmt = $p ? "%.${p}f" : "%d";
1677
return sprintf $fmt, ($is * 100) / ($of ||= 1);
1678
}
1679
1680
sub secs_to_time {
1681
my ( $secs, $fmt ) = @_;
1682
$secs ||= 0;
1683
return '00:00' unless $secs;
1684
1685
$fmt ||= $secs >= 86_400 ? 'd'
1686
: $secs >= 3_600 ? 'h'
1687
: 'm';
1688
1689
return
1690
$fmt eq 'd' ? sprintf(
1691
"%d+%02d:%02d:%02d",
1692
int($secs / 86_400),
1693
int(($secs % 86_400) / 3_600),
1694
int(($secs % 3_600) / 60),
1695
$secs % 60)
1696
: $fmt eq 'h' ? sprintf(
1697
"%02d:%02d:%02d",
1698
int(($secs % 86_400) / 3_600),
1699
int(($secs % 3_600) / 60),
1700
$secs % 60)
1701
: sprintf(
1702
"%02d:%02d",
1703
int(($secs % 3_600) / 60),
1704
$secs % 60);
1705
}
1706
1707
sub time_to_secs {
1708
my ( $val, $default_suffix ) = @_;
1709
die "I need a val argument" unless defined $val;
1710
my $t = 0;
1711
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
1712
$suffix = $suffix || $default_suffix || 's';
1713
if ( $suffix =~ m/[smhd]/ ) {
1714
$t = $suffix eq 's' ? $num * 1 # Seconds
1715
: $suffix eq 'm' ? $num * 60 # Minutes
1716
: $suffix eq 'h' ? $num * 3600 # Hours
1717
: $num * 86400; # Days
1718
1719
$t *= -1 if $prefix && $prefix eq '-';
1720
}
1721
else {
1722
die "Invalid suffix for $val: $suffix";
1723
}
1724
return $t;
1725
}
1726
1727
sub shorten {
1728
my ( $num, %args ) = @_;
1729
my $p = defined $args{p} ? $args{p} : 2; # float precision
1730
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
1731
my $n = 0;
1732
my @units = ('', qw(k M G T P E Z Y));
1733
while ( $num >= $d && $n < @units - 1 ) {
1734
$num /= $d;
1735
++$n;
1736
}
1737
return sprintf(
1738
$num =~ m/\./ || $n
1739
? "%.${p}f%s"
1740
: '%d',
1741
$num, $units[$n]);
1742
}
1743
1744
sub ts {
1745
my ( $time, $gmt ) = @_;
1746
my ( $sec, $min, $hour, $mday, $mon, $year )
1747
= $gmt ? gmtime($time) : localtime($time);
1748
$mon += 1;
1749
$year += 1900;
1750
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
1751
$year, $mon, $mday, $hour, $min, $sec);
1752
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
1753
$us = sprintf("%.6f", $us);
1754
$us =~ s/^0\././;
1755
$val .= $us;
1756
}
1757
return $val;
1758
}
1759
1760
sub parse_timestamp {
1761
my ( $val ) = @_;
1762
if ( my($y, $m, $d, $h, $i, $s, $f)
1763
= $val =~ m/^$mysql_ts$/ )
1764
{
1765
return sprintf "%d-%02d-%02d %02d:%02d:"
1766
. (defined $f ? '%09.6f' : '%02d'),
1767
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
1768
}
1769
return $val;
1770
}
1771
1772
sub unix_timestamp {
1773
my ( $val, $gmt ) = @_;
1774
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
1775
$val = $gmt
1776
? timegm($s, $i, $h, $d, $m - 1, $y)
1777
: timelocal($s, $i, $h, $d, $m - 1, $y);
1778
if ( defined $us ) {
1779
$us = sprintf('%.6f', $us);
1780
$us =~ s/^0\././;
1781
$val .= $us;
1782
}
1783
}
1784
return $val;
1785
}
1786
1787
sub any_unix_timestamp {
1788
my ( $val, $callback ) = @_;
1789
1790
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
1791
$n = $suffix eq 's' ? $n # Seconds
1792
: $suffix eq 'm' ? $n * 60 # Minutes
1793
: $suffix eq 'h' ? $n * 3600 # Hours
1794
: $suffix eq 'd' ? $n * 86400 # Days
1795
: $n; # default: Seconds
1796
MKDEBUG && _d('ts is now - N[shmd]:', $n);
1797
return time - $n;
1798
}
1799
elsif ( $val =~ m/^\d{9,}/ ) {
1800
MKDEBUG && _d('ts is already a unix timestamp');
1801
return $val;
1802
}
1803
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
1804
MKDEBUG && _d('ts is MySQL slow log timestamp');
1805
$val .= ' 00:00:00' unless $hms;
1806
return unix_timestamp(parse_timestamp($val));
1807
}
1808
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
1809
MKDEBUG && _d('ts is properly formatted timestamp');
1810
$val .= ' 00:00:00' unless $hms;
1811
return unix_timestamp($val);
1812
}
1813
else {
1814
MKDEBUG && _d('ts is MySQL expression');
1815
return $callback->($val) if $callback && ref $callback eq 'CODE';
1816
}
1817
1818
MKDEBUG && _d('Unknown ts type:', $val);
1819
return;
1820
}
1821
1822
sub make_checksum {
1823
my ( $val ) = @_;
1824
my $checksum = uc substr(md5_hex($val), -16);
1825
MKDEBUG && _d($checksum, 'checksum for', $val);
1826
return $checksum;
1827
}
1828
1829
sub crc32 {
1830
my ( $string ) = @_;
1831
return unless $string;
1832
my $poly = 0xEDB88320;
1833
my $crc = 0xFFFFFFFF;
1834
foreach my $char ( split(//, $string) ) {
1835
my $comp = ($crc ^ ord($char)) & 0xFF;
1836
for ( 1 .. 8 ) {
1837
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
1838
}
1839
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
1840
}
1841
return $crc ^ 0xFFFFFFFF;
1842
}
1843
1844
sub _d {
1845
my ($package, undef, $line) = caller 0;
1846
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1847
map { defined $_ ? $_ : 'undef' }
1848
@_;
1849
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1850
}
1851
1852
1;
1853
1854
# ###########################################################################
1855
# End Transformers package
1856
# ###########################################################################
1857
1858
# ###########################################################################
1859
# QueryRewriter package 7473
1860
# This package is a copy without comments from the original. The original
1861
# with comments and its test file can be found in the SVN repository at,
1862
# trunk/common/QueryRewriter.pm
1863
# trunk/common/t/QueryRewriter.t
1864
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
1865
# ###########################################################################
1866
use strict;
1867
use warnings FATAL => 'all';
1868
1869
package QueryRewriter;
1870
1871
use English qw(-no_match_vars);
1872
1873
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
1874
1875
our $verbs = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT
1876
|UPDATE|DELETE|REPLACE|^SET|UNION|^START|^LOCK}xi;
1877
my $quote_re = qr/"(?:(?!(?<!\\)").)*"|'(?:(?!(?<!\\)').)*'/; # Costly!
1878
my $bal;
1879
$bal = qr/
1880
\(
1881
(?:
1882
(?> [^()]+ ) # Non-parens without backtracking
1883
|
1884
(??{ $bal }) # Group with matching parens
1885
)*
1886
\)
1887
/x;
1888
1889
my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/; # One-line comments
1890
my $mlc_re = qr#/\*[^!].*?\*/#sm; # But not /*!version */
1891
my $vlc_re = qr#/\*.*?[0-9+].*?\*/#sm; # For SHOW + /*!version */
1892
my $vlc_rf = qr#^(SHOW).*?/\*![0-9+].*?\*/#sm; # Variation for SHOW
1893
1894
1895
sub new {
1896
my ( $class, %args ) = @_;
1897
my $self = { %args };
1898
return bless $self, $class;
1899
}
1900
1901
sub strip_comments {
1902
my ( $self, $query ) = @_;
1903
return unless $query;
1904
$query =~ s/$olc_re//go;
1905
$query =~ s/$mlc_re//go;
1906
if ( $query =~ m/$vlc_rf/i ) { # contains show + version
1907
$query =~ s/$vlc_re//go;
1908
}
1909
return $query;
1910
}
1911
1912
sub shorten {
1913
my ( $self, $query, $length ) = @_;
1914
$query =~ s{
1915
\A(
1916
(?:INSERT|REPLACE)
1917
(?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)?
1918
(?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\)
1919
)
1920
\s*,\s*\(.*?(ON\s+DUPLICATE|\Z)}
1921
{$1 /*... omitted ...*/$2}xsi;
1922
1923
return $query unless $query =~ m/IN\s*\(\s*(?!select)/i;
1924
1925
my $last_length = 0;
1926
my $query_length = length($query);
1927
while (
1928
$length > 0
1929
&& $query_length > $length
1930
&& $query_length < ( $last_length || $query_length + 1 )
1931
) {
1932
$last_length = $query_length;
1933
$query =~ s{
1934
(\bIN\s*\() # The opening of an IN list
1935
([^\)]+) # Contents of the list, assuming no item contains paren
1936
(?=\)) # Close of the list
1937
}
1938
{
1939
$1 . __shorten($2)
1940
}gexsi;
1941
}
1942
1943
return $query;
1944
}
1945
1946
sub __shorten {
1947
my ( $snippet ) = @_;
1948
my @vals = split(/,/, $snippet);
1949
return $snippet unless @vals > 20;
1950
my @keep = splice(@vals, 0, 20); # Remove and save the first 20 items
1951
return
1952
join(',', @keep)
1953
. "/*... omitted "
1954
. scalar(@vals)
1955
. " items ...*/";
1956
}
1957
1958
sub fingerprint {
1959
my ( $self, $query ) = @_;
1960
1961
$query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query
1962
&& return 'mysqldump';
1963
$query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/# # mk-table-checksum, etc query
1964
&& return 'maatkit';
1965
$query =~ m/\Aadministrator command: /
1966
&& return $query;
1967
$query =~ m/\A\s*(call\s+\S+)\(/i
1968
&& return lc($1); # Warning! $1 used, be careful.
1969
if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)?\s+INTO.+?VALUES\s*\(.*?\))\s*,\s*\(/is ) {
1970
$query = $beginning; # Shorten multi-value INSERT statements ASAP
1971
}
1972
1973
$query =~ s/$olc_re//go;
1974
$query =~ s/$mlc_re//go;
1975
$query =~ s/\Ause \S+\Z/use ?/i # Abstract the DB in USE
1976
&& return $query;
1977
1978
$query =~ s/\\["']//g; # quoted strings
1979
$query =~ s/".*?"/?/sg; # quoted strings
1980
$query =~ s/'.*?'/?/sg; # quoted strings
1981
$query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g;# Anything vaguely resembling numbers
1982
$query =~ s/[xb.+-]\?/?/g; # Clean up leftovers
1983
$query =~ s/\A\s+//; # Chop off leading whitespace
1984
chomp $query; # Kill trailing whitespace
1985
$query =~ tr[ \n\t\r\f][ ]s; # Collapse whitespace
1986
$query = lc $query;
1987
$query =~ s/\bnull\b/?/g; # Get rid of NULLs
1988
$query =~ s{ # Collapse IN and VALUES lists
1989
\b(in|values?)(?:[\s,]*\([\s?,]*\))+
1990
}
1991
{$1(?+)}gx;
1992
$query =~ s{ # Collapse UNION
1993
\b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+
1994
}
1995
{$1 /*repeat$2*/}xg;
1996
$query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT
1997
1998
if ( $query =~ m/\bORDER BY /gi ) { # Find, anchor on ORDER BY clause
1999
1 while $query =~ s/\G(.+?)\s+ASC/$1/gi && pos $query;
2000
}
2001
2002
return $query;
2003
}
2004
2005
sub distill_verbs {
2006
my ( $self, $query ) = @_;
2007
2008
$query =~ m/\A\s*call\s+(\S+)\(/i && return "CALL $1";
2009
$query =~ m/\A\s*use\s+/ && return "USE";
2010
$query =~ m/\A\s*UNLOCK TABLES/i && return "UNLOCK";
2011
$query =~ m/\A\s*xa\s+(\S+)/i && return "XA_$1";
2012
2013
if ( $query =~ m/\Aadministrator command:/ ) {
2014
$query =~ s/administrator command:/ADMIN/;
2015
$query = uc $query;
2016
return $query;
2017
}
2018
2019
$query = $self->strip_comments($query);
2020
2021
if ( $query =~ m/\A\s*SHOW\s+/i ) {
2022
MKDEBUG && _d($query);
2023
2024
$query = uc $query;
2025
$query =~ s/\s+(?:GLOBAL|SESSION|FULL|STORAGE|ENGINE)\b/ /g;
2026
$query =~ s/\s+COUNT[^)]+\)//g;
2027
2028
$query =~ s/\s+(?:FOR|FROM|LIKE|WHERE|LIMIT|IN)\b.+//ms;
2029
2030
$query =~ s/\A(SHOW(?:\s+\S+){1,2}).*\Z/$1/s;
2031
$query =~ s/\s+/ /g;
2032
MKDEBUG && _d($query);
2033
return $query;
2034
}
2035
2036
eval $QueryParser::data_def_stmts;
2037
eval $QueryParser::tbl_ident;
2038
my ( $dds ) = $query =~ /^\s*($QueryParser::data_def_stmts)\b/i;
2039
if ( $dds) {
2040
my ( $obj ) = $query =~ m/$dds.+(DATABASE|TABLE)\b/i;
2041
$obj = uc $obj if $obj;
2042
MKDEBUG && _d('Data def statment:', $dds, 'obj:', $obj);
2043
my ($db_or_tbl)
2044
= $query =~ m/(?:TABLE|DATABASE)\s+($QueryParser::tbl_ident)(\s+.*)?/i;
2045
MKDEBUG && _d('Matches db or table:', $db_or_tbl);
2046
return uc($dds . ($obj ? " $obj" : '')), $db_or_tbl;
2047
}
2048
2049
my @verbs = $query =~ m/\b($verbs)\b/gio;
2050
@verbs = do {
2051
my $last = '';
2052
grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs;
2053
};
2054
2055
if ( ($verbs[0] || '') eq 'SELECT' && @verbs > 1 ) {
2056
MKDEBUG && _d("False-positive verbs after SELECT:", @verbs[1..$#verbs]);
2057
my $union = grep { $_ eq 'UNION' } @verbs;
2058
@verbs = $union ? qw(SELECT UNION) : qw(SELECT);
2059
}
2060
2061
my $verb_str = join(q{ }, @verbs);
2062
return $verb_str;
2063
}
2064
2065
sub __distill_tables {
2066
my ( $self, $query, $table, %args ) = @_;
2067
my $qp = $args{QueryParser} || $self->{QueryParser};
2068
die "I need a QueryParser argument" unless $qp;
2069
2070
my @tables = map {
2071
$_ =~ s/`//g;
2072
$_ =~ s/(_?)[0-9]+/$1?/g;
2073
$_;
2074
} grep { defined $_ } $qp->get_tables($query);
2075
2076
push @tables, $table if $table;
2077
2078
@tables = do {
2079
my $last = '';
2080
grep { my $pass = $_ ne $last; $last = $_; $pass } @tables;
2081
};
2082
2083
return @tables;
2084
}
2085
2086
sub distill {
2087
my ( $self, $query, %args ) = @_;
2088
2089
if ( $args{generic} ) {
2090
my ($cmd, $arg) = $query =~ m/^(\S+)\s+(\S+)/;
2091
return '' unless $cmd;
2092
$query = (uc $cmd) . ($arg ? " $arg" : '');
2093
}
2094
else {
2095
my ($verbs, $table) = $self->distill_verbs($query, %args);
2096
2097
if ( $verbs && $verbs =~ m/^SHOW/ ) {
2098
my %alias_for = qw(
2099
SCHEMA DATABASE
2100
KEYS INDEX
2101
INDEXES INDEX
2102
);
2103
map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for;
2104
$query = $verbs;
2105
}
2106
else {
2107
my @tables = $self->__distill_tables($query, $table, %args);
2108
$query = join(q{ }, $verbs, @tables);
2109
}
2110
}
2111
2112
if ( $args{trf} ) {
2113
$query = $args{trf}->($query, %args);
2114
}
2115
2116
return $query;
2117
}
2118
2119
sub convert_to_select {
2120
my ( $self, $query ) = @_;
2121
return unless $query;
2122
2123
return if $query =~ m/=\s*\(\s*SELECT /i;
2124
2125
$query =~ s{
2126
\A.*?
2127
update(?:\s+(?:low_priority|ignore))?\s+(.*?)
2128
\s+set\b(.*?)
2129
(?:\s*where\b(.*?))?
2130
(limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)?
2131
\Z
2132
}
2133
{__update_to_select($1, $2, $3, $4)}exsi
2134
|| $query =~ s{
2135
\A.*?
2136
(?:insert(?:\s+ignore)?|replace)\s+
2137
.*?\binto\b(.*?)\(([^\)]+)\)\s*
2138
values?\s*(\(.*?\))\s*
2139
(?:\blimit\b|on\s+duplicate\s+key.*)?\s*
2140
\Z
2141
}
2142
{__insert_to_select($1, $2, $3)}exsi
2143
|| $query =~ s{
2144
\A.*?
2145
(?:insert(?:\s+ignore)?|replace)\s+
2146
(?:.*?\binto)\b(.*?)\s*
2147
set\s+(.*?)\s*
2148
(?:\blimit\b|on\s+duplicate\s+key.*)?\s*
2149
\Z
2150
}
2151
{__insert_to_select_with_set($1, $2)}exsi
2152
|| $query =~ s{
2153
\A.*?
2154
delete\s+(.*?)
2155
\bfrom\b(.*)
2156
\Z
2157
}
2158
{__delete_to_select($1, $2)}exsi;
2159
$query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si;
2160
$query =~ s/\A.*?(?=\bSELECT\s*\b)//ism;
2161
return $query;
2162
}
2163
2164
sub convert_select_list {
2165
my ( $self, $query ) = @_;
2166
$query =~ s{
2167
\A\s*select(.*?)\bfrom\b
2168
}
2169
{$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi;
2170
return $query;
2171
}
2172
2173
sub __delete_to_select {
2174
my ( $delete, $join ) = @_;
2175
if ( $join =~ m/\bjoin\b/ ) {
2176
return "select 1 from $join";
2177
}
2178
return "select * from $join";
2179
}
2180
2181
sub __insert_to_select {
2182
my ( $tbl, $cols, $vals ) = @_;
2183
MKDEBUG && _d('Args:', @_);
2184
my @cols = split(/,/, $cols);
2185
MKDEBUG && _d('Cols:', @cols);
2186
$vals =~ s/^\(|\)$//g; # Strip leading/trailing parens
2187
my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g;
2188
MKDEBUG && _d('Vals:', @vals);
2189
if ( @cols == @vals ) {
2190
return "select * from $tbl where "
2191
. join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols));
2192
}
2193
else {
2194
return "select * from $tbl limit 1";
2195
}
2196
}
2197
2198
sub __insert_to_select_with_set {
2199
my ( $from, $set ) = @_;
2200
$set =~ s/,/ and /g;
2201
return "select * from $from where $set ";
2202
}
2203
2204
sub __update_to_select {
2205
my ( $from, $set, $where, $limit ) = @_;
2206
return "select $set from $from "
2207
. ( $where ? "where $where" : '' )
2208
. ( $limit ? " $limit " : '' );
2209
}
2210
2211
sub wrap_in_derived {
2212
my ( $self, $query ) = @_;
2213
return unless $query;
2214
return $query =~ m/\A\s*select/i
2215
? "select 1 from ($query) as x limit 1"
2216
: $query;
2217
}
2218
2219
sub _d {
2220
my ($package, undef, $line) = caller 0;
2221
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2222
map { defined $_ ? $_ : 'undef' }
2223
@_;
2224
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2225
}
2226
2227
1;
2228
2229
# ###########################################################################
2230
# End QueryRewriter package
2231
# ###########################################################################
2232
2233
# ###########################################################################
2234
# QueryParser package 7452
2235
# This package is a copy without comments from the original. The original
2236
# with comments and its test file can be found in the SVN repository at,
2237
# trunk/common/QueryParser.pm
2238
# trunk/common/t/QueryParser.t
2239
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
2240
# ###########################################################################
2241
2242
package QueryParser;
2243
2244
use strict;
2245
use warnings FATAL => 'all';
2246
use English qw(-no_match_vars);
2247
2248
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
2249
our $tbl_ident = qr/(?:`[^`]+`|\w+)(?:\.(?:`[^`]+`|\w+))?/;
2250
our $tbl_regex = qr{
2251
\b(?:FROM|JOIN|(?<!KEY\s)UPDATE|INTO) # Words that precede table names
2252
\b\s*
2253
\(? # Optional paren around tables
2254
($tbl_ident
2255
(?: (?:\s+ (?:AS\s+)? \w+)?, \s*$tbl_ident )*
2256
)
2257
}xio;
2258
our $has_derived = qr{
2259
\b(?:FROM|JOIN|,)
2260
\s*\(\s*SELECT
2261
}xi;
2262
2263
our $data_def_stmts = qr/(?:CREATE|ALTER|TRUNCATE|DROP|RENAME)/i;
2264
2265
our $data_manip_stmts = qr/(?:INSERT|UPDATE|DELETE|REPLACE)/i;
2266
2267
sub new {
2268
my ( $class ) = @_;
2269
bless {}, $class;
2270
}
2271
2272
sub get_tables {
2273
my ( $self, $query ) = @_;
2274
return unless $query;
2275
MKDEBUG && _d('Getting tables for', $query);
2276
2277
my ( $ddl_stmt ) = $query =~ m/^\s*($data_def_stmts)\b/i;
2278
if ( $ddl_stmt ) {
2279
MKDEBUG && _d('Special table type:', $ddl_stmt);
2280
$query =~ s/IF\s+(?:NOT\s+)?EXISTS//i;
2281
if ( $query =~ m/$ddl_stmt DATABASE\b/i ) {
2282
MKDEBUG && _d('Query alters a database, not a table');
2283
return ();
2284
}
2285
if ( $ddl_stmt =~ m/CREATE/i && $query =~ m/$ddl_stmt\b.+?\bSELECT\b/i ) {
2286
my ($select) = $query =~ m/\b(SELECT\b.+)/is;
2287
MKDEBUG && _d('CREATE TABLE ... SELECT:', $select);
2288
return $self->get_tables($select);
2289
}
2290
my ($tbl) = $query =~ m/TABLE\s+($tbl_ident)(\s+.*)?/i;
2291
MKDEBUG && _d('Matches table:', $tbl);
2292
return ($tbl);
2293
}
2294
2295
$query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
2296
2297
if ( $query =~ /^\s*LOCK TABLES/i ) {
2298
MKDEBUG && _d('Special table type: LOCK TABLES');
2299
$query =~ s/^(\s*LOCK TABLES\s+)//;
2300
$query =~ s/\s+(?:READ|WRITE|LOCAL)+\s*//g;
2301
MKDEBUG && _d('Locked tables:', $query);
2302
$query = "FROM $query";
2303
}
2304
2305
$query =~ s/\\["']//g; # quoted strings
2306
$query =~ s/".*?"/?/sg; # quoted strings
2307
$query =~ s/'.*?'/?/sg; # quoted strings
2308
2309
my @tables;
2310
foreach my $tbls ( $query =~ m/$tbl_regex/gio ) {
2311
MKDEBUG && _d('Match tables:', $tbls);
2312
2313
next if $tbls =~ m/\ASELECT\b/i;
2314
2315
foreach my $tbl ( split(',', $tbls) ) {
2316
$tbl =~ s/\s*($tbl_ident)(\s+.*)?/$1/gio;
2317
2318
if ( $tbl !~ m/[a-zA-Z]/ ) {
2319
MKDEBUG && _d('Skipping suspicious table name:', $tbl);
2320
next;
2321
}
2322
2323
push @tables, $tbl;
2324
}
2325
}
2326
return @tables;
2327
}
2328
2329
sub has_derived_table {
2330
my ( $self, $query ) = @_;
2331
my $match = $query =~ m/$has_derived/;
2332
MKDEBUG && _d($query, 'has ' . ($match ? 'a' : 'no') . ' derived table');
2333
return $match;
2334
}
2335
2336
sub get_aliases {
2337
my ( $self, $query, $list ) = @_;
2338
2339
my $result = {
2340
DATABASE => {},
2341
TABLE => {},
2342
};
2343
return $result unless $query;
2344
2345
$query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig;
2346
2347
$query =~ s/ (?:INNER|OUTER|CROSS|LEFT|RIGHT|NATURAL)//ig;
2348
2349
my @tbl_refs;
2350
my ($tbl_refs, $from) = $query =~ m{
2351
(
2352
(FROM|INTO|UPDATE)\b\s* # Keyword before table refs
2353
.+? # Table refs
2354
)
2355
(?:\s+|\z) # If the query does not end with the table
2356
(?:WHERE|ORDER|LIMIT|HAVING|SET|VALUES|\z) # Keyword after table refs
2357
}ix;
2358
2359
if ( $tbl_refs ) {
2360
2361
if ( $query =~ m/^(?:INSERT|REPLACE)/i ) {
2362
$tbl_refs =~ s/\([^\)]+\)\s*//;
2363
}
2364
2365
MKDEBUG && _d('tbl refs:', $tbl_refs);
2366
2367
my $before_tbl = qr/(?:,|JOIN|\s|$from)+/i;
2368
2369
my $after_tbl = qr/(?:,|JOIN|ON|USING|\z)/i;
2370
2371
$tbl_refs =~ s/ = /=/g;
2372
2373
while (
2374
$tbl_refs =~ m{
2375
$before_tbl\b\s*
2376
( ($tbl_ident) (?:\s+ (?:AS\s+)? (\w+))? )
2377
\s*$after_tbl
2378
}xgio )
2379
{
2380
my ( $tbl_ref, $db_tbl, $alias ) = ($1, $2, $3);
2381
MKDEBUG && _d('Match table:', $tbl_ref);
2382
push @tbl_refs, $tbl_ref;
2383
$alias = $self->trim_identifier($alias);
2384
2385
if ( $tbl_ref =~ m/^AS\s+\w+/i ) {
2386
MKDEBUG && _d('Subquery', $tbl_ref);
2387
$result->{TABLE}->{$alias} = undef;
2388
next;
2389
}
2390
2391
my ( $db, $tbl ) = $db_tbl =~ m/^(?:(.*?)\.)?(.*)/;
2392
$db = $self->trim_identifier($db);
2393
$tbl = $self->trim_identifier($tbl);
2394
$result->{TABLE}->{$alias || $tbl} = $tbl;
2395
$result->{DATABASE}->{$tbl} = $db if $db;
2396
}
2397
}
2398
else {
2399
MKDEBUG && _d("No tables ref in", $query);
2400
}
2401
2402
if ( $list ) {
2403
return \@tbl_refs;
2404
}
2405
else {
2406
return $result;
2407
}
2408
}
2409
2410
sub split {
2411
my ( $self, $query ) = @_;
2412
return unless $query;
2413
$query = $self->clean_query($query);
2414
MKDEBUG && _d('Splitting', $query);
2415
2416
my $verbs = qr{SELECT|INSERT|UPDATE|DELETE|REPLACE|UNION|CREATE}i;
2417
2418
my @split_statements = grep { $_ } split(m/\b($verbs\b(?!(?:\s*\()))/io, $query);
2419
2420
my @statements;
2421
if ( @split_statements == 1 ) {
2422
push @statements, $query;
2423
}
2424
else {
2425
for ( my $i = 0; $i <= $#split_statements; $i += 2 ) {
2426
push @statements, $split_statements[$i].$split_statements[$i+1];
2427
2428
if ( $statements[-2] && $statements[-2] =~ m/on duplicate key\s+$/i ) {
2429
$statements[-2] .= pop @statements;
2430
}
2431
}
2432
}
2433
2434
MKDEBUG && _d('statements:', map { $_ ? "<$_>" : 'none' } @statements);
2435
return @statements;
2436
}
2437
2438
sub clean_query {
2439
my ( $self, $query ) = @_;
2440
return unless $query;
2441
$query =~ s!/\*.*?\*/! !g; # Remove /* comment blocks */
2442
$query =~ s/^\s+//; # Remove leading spaces
2443
$query =~ s/\s+$//; # Remove trailing spaces
2444
$query =~ s/\s{2,}/ /g; # Remove extra spaces
2445
return $query;
2446
}
2447
2448
sub split_subquery {
2449
my ( $self, $query ) = @_;
2450
return unless $query;
2451
$query = $self->clean_query($query);
2452
$query =~ s/;$//;
2453
2454
my @subqueries;
2455
my $sqno = 0; # subquery number
2456
my $pos = 0;
2457
while ( $query =~ m/(\S+)(?:\s+|\Z)/g ) {
2458
$pos = pos($query);
2459
my $word = $1;
2460
MKDEBUG && _d($word, $sqno);
2461
if ( $word =~ m/^\(?SELECT\b/i ) {
2462
my $start_pos = $pos - length($word) - 1;
2463
if ( $start_pos ) {
2464
$sqno++;
2465
MKDEBUG && _d('Subquery', $sqno, 'starts at', $start_pos);
2466
$subqueries[$sqno] = {
2467
start_pos => $start_pos,
2468
end_pos => 0,
2469
len => 0,
2470
words => [$word],
2471
lp => 1, # left parentheses
2472
rp => 0, # right parentheses
2473
done => 0,
2474
};
2475
}
2476
else {
2477
MKDEBUG && _d('Main SELECT at pos 0');
2478
}
2479
}
2480
else {
2481
next unless $sqno; # next unless we're in a subquery
2482
MKDEBUG && _d('In subquery', $sqno);
2483
my $sq = $subqueries[$sqno];
2484
if ( $sq->{done} ) {
2485
MKDEBUG && _d('This subquery is done; SQL is for',
2486
($sqno - 1 ? "subquery $sqno" : "the main SELECT"));
2487
next;
2488
}
2489
push @{$sq->{words}}, $word;
2490
my $lp = ($word =~ tr/\(//) || 0;
2491
my $rp = ($word =~ tr/\)//) || 0;
2492
MKDEBUG && _d('parentheses left', $lp, 'right', $rp);
2493
if ( ($sq->{lp} + $lp) - ($sq->{rp} + $rp) == 0 ) {
2494
my $end_pos = $pos - 1;
2495
MKDEBUG && _d('Subquery', $sqno, 'ends at', $end_pos);
2496
$sq->{end_pos} = $end_pos;
2497
$sq->{len} = $end_pos - $sq->{start_pos};
2498
}
2499
}
2500
}
2501
2502
for my $i ( 1..$#subqueries ) {
2503
my $sq = $subqueries[$i];
2504
next unless $sq;
2505
$sq->{sql} = join(' ', @{$sq->{words}});
2506
substr $query,
2507
$sq->{start_pos} + 1, # +1 for (
2508
$sq->{len} - 1, # -1 for )
2509
"__subquery_$i";
2510
}
2511
2512
return $query, map { $_->{sql} } grep { defined $_ } @subqueries;
2513
}
2514
2515
sub query_type {
2516
my ( $self, $query, $qr ) = @_;
2517
my ($type, undef) = $qr->distill_verbs($query);
2518
my $rw;
2519
if ( $type =~ m/^SELECT\b/ ) {
2520
$rw = 'read';
2521
}
2522
elsif ( $type =~ m/^$data_manip_stmts\b/
2523
|| $type =~ m/^$data_def_stmts\b/ ) {
2524
$rw = 'write'
2525
}
2526
2527
return {
2528
type => $type,
2529
rw => $rw,
2530
}
2531
}
2532
2533
sub get_columns {
2534
my ( $self, $query ) = @_;
2535
my $cols = [];
2536
return $cols unless $query;
2537
my $cols_def;
2538
2539
if ( $query =~ m/^SELECT/i ) {
2540
$query =~ s/
2541
^SELECT\s+
2542
(?:ALL
2543
|DISTINCT
2544
|DISTINCTROW
2545
|HIGH_PRIORITY
2546
|STRAIGHT_JOIN
2547
|SQL_SMALL_RESULT
2548
|SQL_BIG_RESULT
2549
|SQL_BUFFER_RESULT
2550
|SQL_CACHE
2551
|SQL_NO_CACHE
2552
|SQL_CALC_FOUND_ROWS
2553
)\s+
2554
/SELECT /xgi;
2555
($cols_def) = $query =~ m/^SELECT\s+(.+?)\s+FROM/i;
2556
}
2557
elsif ( $query =~ m/^(?:INSERT|REPLACE)/i ) {
2558
($cols_def) = $query =~ m/\(([^\)]+)\)\s*VALUE/i;
2559
}
2560
2561
MKDEBUG && _d('Columns:', $cols_def);
2562
if ( $cols_def ) {
2563
@$cols = split(',', $cols_def);
2564
map {
2565
my $col = $_;
2566
$col = s/^\s+//g;
2567
$col = s/\s+$//g;
2568
$col;
2569
} @$cols;
2570
}
2571
2572
return $cols;
2573
}
2574
2575
sub parse {
2576
my ( $self, $query ) = @_;
2577
return unless $query;
2578
my $parsed = {};
2579
2580
$query =~ s/\n/ /g;
2581
$query = $self->clean_query($query);
2582
2583
$parsed->{query} = $query,
2584
$parsed->{tables} = $self->get_aliases($query, 1);
2585
$parsed->{columns} = $self->get_columns($query);
2586
2587
my ($type) = $query =~ m/^(\w+)/;
2588
$parsed->{type} = lc $type;
2589
2590
2591
$parsed->{sub_queries} = [];
2592
2593
return $parsed;
2594
}
2595
2596
sub extract_tables {
2597
my ( $self, %args ) = @_;
2598
my $query = $args{query};
2599
my $default_db = $args{default_db};
2600
my $q = $self->{Quoter} || $args{Quoter};
2601
return unless $query;
2602
MKDEBUG && _d('Extracting tables');
2603
my @tables;
2604
my %seen;
2605
foreach my $db_tbl ( $self->get_tables($query) ) {
2606
next unless $db_tbl;
2607
next if $seen{$db_tbl}++; # Unique-ify for issue 337.
2608
my ( $db, $tbl ) = $q->split_unquote($db_tbl);
2609
push @tables, [ $db || $default_db, $tbl ];
2610
}
2611
return @tables;
2612
}
2613
2614
sub trim_identifier {
2615
my ($self, $str) = @_;
2616
return unless defined $str;
2617
$str =~ s/`//g;
2618
$str =~ s/^\s+//;
2619
$str =~ s/\s+$//;
2620
return $str;
2621
}
2622
2623
sub _d {
2624
my ($package, undef, $line) = caller 0;
2625
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2626
map { defined $_ ? $_ : 'undef' }
2627
@_;
2628
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2629
}
2630
2631
1;
2632
2633
# ###########################################################################
2634
# End QueryParser package
2635
# ###########################################################################
2636
2637
# ###########################################################################
2638
# FileIterator package 7096
2639
# This package is a copy without comments from the original. The original
2640
# with comments and its test file can be found in the SVN repository at,
2641
# trunk/common/FileIterator.pm
2642
# trunk/common/t/FileIterator.t
2643
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
2644
# ###########################################################################
2645
package FileIterator;
2646
2647
use strict;
2648
use warnings FATAL => 'all';
2649
2650
use English qw(-no_match_vars);
2651
use Data::Dumper;
2652
$Data::Dumper::Indent = 1;
2653
$Data::Dumper::Sortkeys = 1;
2654
$Data::Dumper::Quotekeys = 0;
2655
2656
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
2657
2658
sub new {
2659
my ( $class, %args ) = @_;
2660
my $self = {
2661
%args,
2662
};
2663
return bless $self, $class;
2664
}
2665
2666
sub get_file_itr {
2667
my ( $self, @filenames ) = @_;
2668
2669
my @final_filenames;
2670
FILENAME:
2671
foreach my $fn ( @filenames ) {
2672
if ( !defined $fn ) {
2673
warn "Skipping undefined filename";
2674
next FILENAME;
2675
}
2676
if ( $fn ne '-' ) {
2677
if ( !-e $fn || !-r $fn ) {
2678
warn "$fn does not exist or is not readable";
2679
next FILENAME;
2680
}
2681
}
2682
push @final_filenames, $fn;
2683
}
2684
2685
if ( !@filenames ) {
2686
push @final_filenames, '-';
2687
MKDEBUG && _d('Auto-adding "-" to the list of filenames');
2688
}
2689
2690
MKDEBUG && _d('Final filenames:', @final_filenames);
2691
return sub {
2692
while ( @final_filenames ) {
2693
my $fn = shift @final_filenames;
2694
MKDEBUG && _d('Filename:', $fn);
2695
if ( $fn eq '-' ) { # Magical STDIN filename.
2696
return (*STDIN, undef, undef);
2697
}
2698
open my $fh, '<', $fn or warn "Cannot open $fn: $OS_ERROR";
2699
if ( $fh ) {
2700
return ( $fh, $fn, -s $fn );
2701
}
2702
}
2703
return (); # Avoids $f being set to 0 in list context.
2704
};
2705
}
2706
2707
sub _d {
2708
my ($package, undef, $line) = caller 0;
2709
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2710
map { defined $_ ? $_ : 'undef' }
2711
@_;
2712
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2713
}
2714
2715
1;
2716
2717
# ###########################################################################
2718
# End FileIterator package
2719
# ###########################################################################
2720
2721
# ###########################################################################
2722
# SQLParser package 7497
2723
# This package is a copy without comments from the original. The original
2724
# with comments and its test file can be found in the SVN repository at,
2725
# trunk/common/SQLParser.pm
2726
# trunk/common/t/SQLParser.t
2727
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
2728
# ###########################################################################
2729
2730
package SQLParser;
2731
2732
{ # package scope
2733
use strict;
2734
use warnings FATAL => 'all';
2735
use English qw(-no_match_vars);
2736
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
2737
2738
use Data::Dumper;
2739
$Data::Dumper::Indent = 1;
2740
$Data::Dumper::Sortkeys = 1;
2741
$Data::Dumper::Quotekeys = 0;
2742
2743
my $quoted_ident = qr/`[^`]+`/;
2744
my $unquoted_ident = qr/
2745
\@{0,2} # optional @ or @@ for variables
2746
\w+ # the ident name
2747
(?:\([^\)]*\))? # optional function params
2748
/x;
2749
2750
my $ident_alias = qr/
2751
\s+ # space before alias
2752
(?:(AS)\s+)? # optional AS keyword
2753
((?>$quoted_ident|$unquoted_ident)) # alais
2754
/xi;
2755
2756
my $table_ident = qr/(?:
2757
((?:(?>$quoted_ident|$unquoted_ident)\.?){1,2}) # table
2758
(?:$ident_alias)? # optional alias
2759
)/xo;
2760
2761
my $column_ident = qr/(?:
2762
((?:(?>$quoted_ident|$unquoted_ident|\*)\.?){1,3}) # column
2763
(?:$ident_alias)? # optional alias
2764
)/xo;
2765
2766
sub new {
2767
my ( $class, %args ) = @_;
2768
my $self = {
2769
%args,
2770
};
2771
return bless $self, $class;
2772
}
2773
2774
sub parse {
2775
my ( $self, $query ) = @_;
2776
return unless $query;
2777
2778
my $allowed_types = qr/(?:
2779
DELETE
2780
|INSERT
2781
|REPLACE
2782
|SELECT
2783
|UPDATE
2784
)/xi;
2785
2786
$query = $self->clean_query($query);
2787
2788
my $type;
2789
if ( $query =~ s/^(\w+)\s+// ) {
2790
$type = lc $1;
2791
MKDEBUG && _d('Query type:', $type);
2792
die "Cannot parse " . uc($type) . " queries"
2793
unless $type =~ m/$allowed_types/i;
2794
}
2795
else {
2796
die "Query does not begin with a word"; # shouldn't happen
2797
}
2798
2799
$query = $self->normalize_keyword_spaces($query);
2800
2801
my @subqueries;
2802
if ( $query =~ m/(\(SELECT )/i ) {
2803
MKDEBUG && _d('Removing subqueries');
2804
@subqueries = $self->remove_subqueries($query);
2805
$query = shift @subqueries;
2806
}
2807
2808
my $parse_func = "parse_$type";
2809
my $struct = $self->$parse_func($query);
2810
if ( !$struct ) {
2811
MKDEBUG && _d($parse_func, 'failed to parse query');
2812
return;
2813
}
2814
$struct->{type} = $type;
2815
$self->_parse_clauses($struct);
2816
2817
if ( @subqueries ) {
2818
MKDEBUG && _d('Parsing subqueries');
2819
foreach my $subquery ( @subqueries ) {
2820
my $subquery_struct = $self->parse($subquery->{query});
2821
@{$subquery_struct}{keys %$subquery} = values %$subquery;
2822
push @{$struct->{subqueries}}, $subquery_struct;
2823
}
2824
}
2825
2826
MKDEBUG && _d('Query struct:', Dumper($struct));
2827
return $struct;
2828
}
2829
2830
2831
sub _parse_clauses {
2832
my ( $self, $struct ) = @_;
2833
foreach my $clause ( keys %{$struct->{clauses}} ) {
2834
if ( $clause =~ m/ / ) {
2835
(my $clause_no_space = $clause) =~ s/ /_/g;
2836
$struct->{clauses}->{$clause_no_space} = $struct->{clauses}->{$clause};
2837
delete $struct->{clauses}->{$clause};
2838
$clause = $clause_no_space;
2839
}
2840
2841
my $parse_func = "parse_$clause";
2842
$struct->{$clause} = $self->$parse_func($struct->{clauses}->{$clause});
2843
2844
if ( $clause eq 'select' ) {
2845
MKDEBUG && _d('Parsing subquery clauses');
2846
$struct->{select}->{type} = 'select';
2847
$self->_parse_clauses($struct->{select});
2848
}
2849
}
2850
return;
2851
}
2852
2853
sub clean_query {
2854
my ( $self, $query ) = @_;
2855
return unless $query;
2856
2857
$query =~ s/^\s*--.*$//gm; # -- comments
2858
$query =~ s/\s+/ /g; # extra spaces/flatten
2859
$query =~ s!/\*.*?\*/!!g; # /* comments */
2860
$query =~ s/^\s+//; # leading spaces
2861
$query =~ s/\s+$//; # trailing spaces
2862
2863
return $query;
2864
}
2865
2866
sub normalize_keyword_spaces {
2867
my ( $self, $query ) = @_;
2868
2869
$query =~ s/\b(VALUE(?:S)?)\(/$1 (/i;
2870
$query =~ s/\bON\(/on (/gi;
2871
$query =~ s/\bUSING\(/using (/gi;
2872
2873
$query =~ s/\(\s+SELECT\s+/(SELECT /gi;
2874
2875
return $query;
2876
}
2877
2878
sub _parse_query {
2879
my ( $self, $query, $keywords, $first_clause, $clauses ) = @_;
2880
return unless $query;
2881
my $struct = {};
2882
2883
1 while $query =~ s/$keywords\s+/$struct->{keywords}->{lc $1}=1, ''/gie;
2884
2885
my @clause = grep { defined $_ }
2886
($query =~ m/\G(.+?)(?:$clauses\s+|\Z)/gci);
2887
2888
my $clause = $first_clause,
2889
my $value = shift @clause;
2890
$struct->{clauses}->{$clause} = $value;
2891
MKDEBUG && _d('Clause:', $clause, $value);
2892
2893
while ( @clause ) {
2894
$clause = shift @clause;
2895
$value = shift @clause;
2896
$struct->{clauses}->{lc $clause} = $value;
2897
MKDEBUG && _d('Clause:', $clause, $value);
2898
}
2899
2900
($struct->{unknown}) = ($query =~ m/\G(.+)/);
2901
2902
return $struct;
2903
}
2904
2905
sub parse_delete {
2906
my ( $self, $query ) = @_;
2907
if ( $query =~ s/FROM\s+//i ) {
2908
my $keywords = qr/(LOW_PRIORITY|QUICK|IGNORE)/i;
2909
my $clauses = qr/(FROM|WHERE|ORDER BY|LIMIT)/i;
2910
return $self->_parse_query($query, $keywords, 'from', $clauses);
2911
}
2912
else {
2913
die "DELETE without FROM: $query";
2914
}
2915
}
2916
2917
sub parse_insert {
2918
my ( $self, $query ) = @_;
2919
return unless $query;
2920
my $struct = {};
2921
2922
my $keywords = qr/(LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)/i;
2923
1 while $query =~ s/$keywords\s+/$struct->{keywords}->{lc $1}=1, ''/gie;
2924
2925
if ( $query =~ m/ON DUPLICATE KEY UPDATE (.+)/i ) {
2926
my $values = $1;
2927
die "No values after ON DUPLICATE KEY UPDATE: $query" unless $values;
2928
$struct->{clauses}->{on_duplicate} = $values;
2929
MKDEBUG && _d('Clause: on duplicate key update', $values);
2930
2931
$query =~ s/\s+ON DUPLICATE KEY UPDATE.+//;
2932
}
2933
2934
if ( my @into = ($query =~ m/
2935
(?:INTO\s+)? # INTO, optional
2936
(.+?)\s+ # table ref
2937
(\([^\)]+\)\s+)? # column list, optional
2938
(VALUE.?|SET|SELECT)\s+ # start of next caluse
2939
/xgci)
2940
) {
2941
my $tbl = shift @into; # table ref
2942
$struct->{clauses}->{into} = $tbl;
2943
MKDEBUG && _d('Clause: into', $tbl);
2944
2945
my $cols = shift @into; # columns, maybe
2946
if ( $cols ) {
2947
$cols =~ s/[\(\)]//g;
2948
$struct->{clauses}->{columns} = $cols;
2949
MKDEBUG && _d('Clause: columns', $cols);
2950
}
2951
2952
my $next_clause = lc(shift @into); # VALUES, SET or SELECT
2953
die "INSERT/REPLACE without clause after table: $query"
2954
unless $next_clause;
2955
$next_clause = 'values' if $next_clause eq 'value';
2956
my ($values) = ($query =~ m/\G(.+)/gci);
2957
die "INSERT/REPLACE without values: $query" unless $values;
2958
$struct->{clauses}->{$next_clause} = $values;
2959
MKDEBUG && _d('Clause:', $next_clause, $values);
2960
}
2961
2962
($struct->{unknown}) = ($query =~ m/\G(.+)/);
2963
2964
return $struct;
2965
}
2966
{
2967
no warnings;
2968
*parse_replace = \&parse_insert;
2969
}
2970
2971
sub parse_select {
2972
my ( $self, $query ) = @_;
2973
2974
my @keywords;
2975
my $final_keywords = qr/(FOR UPDATE|LOCK IN SHARE MODE)/i;
2976
1 while $query =~ s/\s+$final_keywords/(push @keywords, $1), ''/gie;
2977
2978
my $keywords = qr/(
2979
ALL
2980
|DISTINCT
2981
|DISTINCTROW
2982
|HIGH_PRIORITY
2983
|STRAIGHT_JOIN
2984
|SQL_SMALL_RESULT
2985
|SQL_BIG_RESULT
2986
|SQL_BUFFER_RESULT
2987
|SQL_CACHE
2988
|SQL_NO_CACHE
2989
|SQL_CALC_FOUND_ROWS
2990
)/xi;
2991
my $clauses = qr/(
2992
FROM
2993
|WHERE
2994
|GROUP\sBY
2995
|HAVING
2996
|ORDER\sBY
2997
|LIMIT
2998
|PROCEDURE
2999
|INTO OUTFILE
3000
)/xi;
3001
my $struct = $self->_parse_query($query, $keywords, 'columns', $clauses);
3002
3003
map { s/ /_/g; $struct->{keywords}->{lc $_} = 1; } @keywords;
3004
3005
return $struct;
3006
}
3007
3008
sub parse_update {
3009
my $keywords = qr/(LOW_PRIORITY|IGNORE)/i;
3010
my $clauses = qr/(SET|WHERE|ORDER BY|LIMIT)/i;
3011
return _parse_query(@_, $keywords, 'tables', $clauses);
3012
3013
}
3014
3015
sub parse_from {
3016
my ( $self, $from ) = @_;
3017
return unless $from;
3018
MKDEBUG && _d('Parsing FROM', $from);
3019
3020
my $comma_join = qr/(?>\s*,\s*)/;
3021
my $ansi_join = qr/(?>
3022
\s+
3023
(?:(?:INNER|CROSS|STRAIGHT_JOIN|LEFT|RIGHT|OUTER|NATURAL)\s+)*
3024
JOIN
3025
\s+
3026
)/xi;
3027
3028
my @tbls; # all table refs, a hashref for each
3029
my $tbl_ref; # current table ref hashref
3030
my $join; # join info hahsref for current table ref
3031
foreach my $thing ( split /($comma_join|$ansi_join)/io, $from ) {
3032
die "Error parsing FROM clause" unless $thing;
3033
3034
$thing =~ s/^\s+//;
3035
$thing =~ s/\s+$//;
3036
MKDEBUG && _d('Table thing:', $thing);
3037
3038
if ( $thing =~ m/\s+(?:ON|USING)\s+/i ) {
3039
MKDEBUG && _d("JOIN condition");
3040
my ($tbl_ref_txt, $join_condition_verb, $join_condition_value)
3041
= $thing =~ m/^(.+?)\s+(ON|USING)\s+(.+)/i;
3042
3043
$tbl_ref = $self->parse_table_reference($tbl_ref_txt);
3044
3045
$join->{condition} = lc $join_condition_verb;
3046
if ( $join->{condition} eq 'on' ) {
3047
my $where = $self->parse_where($join_condition_value);
3048
$join->{where} = $where;
3049
}
3050
else { # USING
3051
$join_condition_value =~ s/^\s*\(//;
3052
$join_condition_value =~ s/\)\s*$//;
3053
$join->{columns} = $self->_parse_csv($join_condition_value);
3054
}
3055
}
3056
elsif ( $thing =~ m/(?:,|JOIN)/i ) {
3057
if ( $join ) {
3058
$tbl_ref->{join} = $join;
3059
}
3060
push @tbls, $tbl_ref;
3061
MKDEBUG && _d("Complete table reference:", Dumper($tbl_ref));
3062
3063
$tbl_ref = undef;
3064
$join = {};
3065
3066
$join->{to} = $tbls[-1]->{tbl};
3067
if ( $thing eq ',' ) {
3068
$join->{type} = 'inner';
3069
$join->{ansi} = 0;
3070
}
3071
else { # ansi join
3072
my $type = $thing =~ m/^(.+?)\s+JOIN$/i ? lc $1 : 'inner';
3073
$join->{type} = $type;
3074
$join->{ansi} = 1;
3075
}
3076
}
3077
else {
3078
$tbl_ref = $self->parse_table_reference($thing);
3079
MKDEBUG && _d('Table reference:', Dumper($tbl_ref));
3080
}
3081
}
3082
3083
if ( $tbl_ref ) {
3084
if ( $join ) {
3085
$tbl_ref->{join} = $join;
3086
}
3087
push @tbls, $tbl_ref;
3088
MKDEBUG && _d("Complete table reference:", Dumper($tbl_ref));
3089
}
3090
3091
return \@tbls;
3092
}
3093
3094
sub parse_table_reference {
3095
my ( $self, $tbl_ref ) = @_;
3096
return unless $tbl_ref;
3097
MKDEBUG && _d('Parsing table reference:', $tbl_ref);
3098
my %tbl;
3099
3100
if ( $tbl_ref =~ s/
3101
\s+(
3102
(?:FORCE|USE|INGORE)\s
3103
(?:INDEX|KEY)
3104
\s*\([^\)]+\)\s*
3105
)//xi)
3106
{
3107
$tbl{index_hint} = $1;
3108
MKDEBUG && _d('Index hint:', $tbl{index_hint});
3109
}
3110
3111
if ( $tbl_ref =~ m/$table_ident/ ) {
3112
my ($db_tbl, $as, $alias) = ($1, $2, $3); # XXX
3113
my $ident_struct = $self->parse_identifier('table', $db_tbl);
3114
$alias =~ s/`//g if $alias;
3115
@tbl{keys %$ident_struct} = values %$ident_struct;
3116
$tbl{explicit_alias} = 1 if $as;
3117
$tbl{alias} = $alias if $alias;
3118
}
3119
else {
3120
die "Table ident match failed"; # shouldn't happen
3121
}
3122
3123
return \%tbl;
3124
}
3125
{
3126
no warnings; # Why? See same line above.
3127
*parse_into = \&parse_from;
3128
*parse_tables = \&parse_from;
3129
}
3130
3131
sub parse_where {
3132
my ( $self, $where ) = @_;
3133
return unless $where;
3134
MKDEBUG && _d("Parsing WHERE", $where);
3135
3136
my $op_symbol = qr/
3137
(?:
3138
<=
3139
|>=
3140
|<>
3141
|!=
3142
|<
3143
|>
3144
|=
3145
)/xi;
3146
my $op_verb = qr/
3147
(?:
3148
(?:(?:NOT\s)?LIKE)
3149
|(?:IS(?:\sNOT\s)?)
3150
|(?:(?:\sNOT\s)?BETWEEN)
3151
|(?:(?:NOT\s)?IN)
3152
)
3153
/xi;
3154
my $op_pat = qr/
3155
(
3156
(?>
3157
(?:$op_symbol) # don't need spaces around the symbols, e.g.: col=1
3158
|(?:\s+$op_verb) # must have space before verb op, e.g.: col LIKE ...
3159
)
3160
)/x;
3161
3162
my $offset = 0;
3163
my $pred = "";
3164
my @pred;
3165
my @has_op;
3166
while ( $where =~ m/\b(and|or)\b/gi ) {
3167
my $pos = (pos $where) - (length $1); # pos at and|or, not after
3168
3169
$pred = substr $where, $offset, ($pos-$offset);
3170
push @pred, $pred;
3171
push @has_op, $pred =~ m/$op_pat/o ? 1 : 0;
3172
3173
$offset = $pos;
3174
}
3175
$pred = substr $where, $offset;
3176
push @pred, $pred;
3177
push @has_op, $pred =~ m/$op_pat/o ? 1 : 0;
3178
MKDEBUG && _d("Predicate fragments:", Dumper(\@pred));
3179
MKDEBUG && _d("Predicate frags with operators:", @has_op);
3180
3181
my $n = scalar @pred - 1;
3182
for my $i ( 1..$n ) {
3183
$i *= -1;
3184
my $j = $i - 1; # preceding pred frag
3185
3186
next if $pred[$j] !~ m/\s+between\s+/i && $self->_is_constant($pred[$i]);
3187
3188
if ( !$has_op[$i] ) {
3189
$pred[$j] .= $pred[$i];
3190
$pred[$i] = undef;
3191
}
3192
}
3193
MKDEBUG && _d("Predicate fragments joined:", Dumper(\@pred));
3194
3195
for my $i ( 0..@pred ) {
3196
$pred = $pred[$i];
3197
next unless defined $pred;
3198
my $n_single_quotes = ($pred =~ tr/'//);
3199
my $n_double_quotes = ($pred =~ tr/"//);
3200
if ( ($n_single_quotes % 2) || ($n_double_quotes % 2) ) {
3201
$pred[$i] .= $pred[$i + 1];
3202
$pred[$i + 1] = undef;
3203
}
3204
}
3205
MKDEBUG && _d("Predicate fragments balanced:", Dumper(\@pred));
3206
3207
my @predicates;
3208
foreach my $pred ( @pred ) {
3209
next unless defined $pred;
3210
$pred =~ s/^\s+//;
3211
$pred =~ s/\s+$//;
3212
my $conj;
3213
if ( $pred =~ s/^(and|or)\s+//i ) {
3214
$conj = lc $1;
3215
}
3216
my ($col, $op, $val) = $pred =~ m/^(.+?)$op_pat(.+)$/o;
3217
if ( !$col || !$op ) {
3218
if ( $self->_is_constant($pred) ) {
3219
$val = lc $pred;
3220
}
3221
else {
3222
die "Failed to parse WHERE condition: $pred";
3223
}
3224
}
3225
3226
if ( $col ) {
3227
$col =~ s/\s+$//;
3228
$col =~ s/^\(+//; # no unquoted column name begins with (
3229
}
3230
if ( $op ) {
3231
$op = lc $op;
3232
$op =~ s/^\s+//;
3233
$op =~ s/\s+$//;
3234
}
3235
$val =~ s/^\s+//;
3236
3237
if ( ($op || '') !~ m/IN/i && $val !~ m/^\w+\([^\)]+\)$/ ) {
3238
$val =~ s/\)+$//;
3239
}
3240
3241
if ( $val =~ m/NULL|TRUE|FALSE/i ) {
3242
$val = lc $val;
3243
}
3244
3245
push @predicates, {
3246
predicate => $conj,
3247
left_arg => $col,
3248
operator => $op,
3249
right_arg => $val,
3250
};
3251
}
3252
3253
return \@predicates;
3254
}
3255
3256
sub _is_constant {
3257
my ( $self, $val ) = @_;
3258
return 0 unless defined $val;
3259
$val =~ s/^\s*(?:and|or)\s+//;
3260
return
3261
$val =~ m/^\s*(?:TRUE|FALSE)\s*$/i || $val =~ m/^\s*-?\d+\s*$/ ? 1 : 0;
3262
}
3263
3264
sub parse_having {
3265
my ( $self, $having ) = @_;
3266
return $having;
3267
}
3268
3269
sub parse_group_by {
3270
my ( $self, $group_by ) = @_;
3271
return unless $group_by;
3272
MKDEBUG && _d('Parsing GROUP BY', $group_by);
3273
3274
my $with_rollup = $group_by =~ s/\s+WITH ROLLUP\s*//i;
3275
3276
my $idents = $self->parse_identifiers( $self->_parse_csv($group_by) );
3277
3278
$idents->{with_rollup} = 1 if $with_rollup;
3279
3280
return $idents;
3281
}
3282
3283
sub parse_order_by {
3284
my ( $self, $order_by ) = @_;
3285
return unless $order_by;
3286
MKDEBUG && _d('Parsing ORDER BY', $order_by);
3287
my $idents = $self->parse_identifiers( $self->_parse_csv($order_by) );
3288
return $idents;
3289
}
3290
3291
sub parse_limit {
3292
my ( $self, $limit ) = @_;
3293
return unless $limit;
3294
my $struct = {
3295
row_count => undef,
3296
};
3297
if ( $limit =~ m/(\S+)\s+OFFSET\s+(\S+)/i ) {
3298
$struct->{explicit_offset} = 1;
3299
$struct->{row_count} = $1;
3300
$struct->{offset} = $2;
3301
}
3302
else {
3303
my ($offset, $cnt) = $limit =~ m/(?:(\S+),\s+)?(\S+)/i;
3304
$struct->{row_count} = $cnt;
3305
$struct->{offset} = $offset if defined $offset;
3306
}
3307
return $struct;
3308
}
3309
3310
sub parse_values {
3311
my ( $self, $values ) = @_;
3312
return unless $values;
3313
$values =~ s/^\s*\(//;
3314
$values =~ s/\s*\)//;
3315
my $vals = $self->_parse_csv(
3316
$values,
3317
quoted_values => 1,
3318
remove_quotes => 0,
3319
);
3320
return $vals;
3321
}
3322
3323
sub parse_set {
3324
my ( $self, $set ) = @_;
3325
MKDEBUG && _d("Parse SET", $set);
3326
return unless $set;
3327
my $vals = $self->_parse_csv($set);
3328
return unless $vals && @$vals;
3329
3330
my @set;
3331
foreach my $col_val ( @$vals ) {
3332
my ($col, $val) = $col_val =~ m/^([^=]+)\s*=\s*(.+)/;
3333
my $ident_struct = $self->parse_identifier('column', $col);
3334
my $set_struct = {
3335
%$ident_struct,
3336
value => $val,
3337
};
3338
MKDEBUG && _d("SET:", Dumper($set_struct));
3339
push @set, $set_struct;
3340
}
3341
return \@set;
3342
}
3343
3344
sub _parse_csv {
3345
my ( $self, $vals, %args ) = @_;
3346
return unless $vals;
3347
3348
my @vals;
3349
if ( $args{quoted_values} ) {
3350
my $quote_char = '';
3351
VAL:
3352
foreach my $val ( split(',', $vals) ) {
3353
MKDEBUG && _d("Next value:", $val);
3354
if ( $quote_char ) {
3355
MKDEBUG && _d("Value is part of previous quoted value");
3356
$vals[-1] .= ",$val";
3357
3358
if ( $val =~ m/[^\\]*$quote_char$/ ) {
3359
if ( $args{remove_quotes} ) {
3360
$vals[-1] =~ s/^\s*$quote_char//;
3361
$vals[-1] =~ s/$quote_char\s*$//;
3362
}
3363
MKDEBUG && _d("Previous quoted value is complete:", $vals[-1]);
3364
$quote_char = '';
3365
}
3366
3367
next VAL;
3368
}
3369
3370
$val =~ s/^\s+//;
3371
3372
if ( $val =~ m/^(['"])/ ) {
3373
MKDEBUG && _d("Value is quoted");
3374
$quote_char = $1; # XXX
3375
if ( $val =~ m/.$quote_char$/ ) {
3376
MKDEBUG && _d("Value is complete");
3377
$quote_char = '';
3378
if ( $args{remove_quotes} ) {
3379
$vals[-1] =~ s/^\s*$quote_char//;
3380
$vals[-1] =~ s/$quote_char\s*$//;
3381
}
3382
}
3383
else {
3384
MKDEBUG && _d("Quoted value is not complete");
3385
}
3386
}
3387
else {
3388
$val =~ s/\s+$//;
3389
}
3390
3391
MKDEBUG && _d("Saving value", ($quote_char ? "fragment" : ""));
3392
push @vals, $val;
3393
}
3394
}
3395
else {
3396
@vals = map { s/^\s+//; s/\s+$//; $_ } split(',', $vals);
3397
}
3398
3399
return \@vals;
3400
}
3401
{
3402
no warnings; # Why? See same line above.
3403
*parse_on_duplicate = \&_parse_csv;
3404
}
3405
3406
sub parse_columns {
3407
my ( $self, $cols ) = @_;
3408
MKDEBUG && _d('Parsing columns list:', $cols);
3409
3410
my @cols;
3411
pos $cols = 0;
3412
while (pos $cols < length $cols) {
3413
if ($cols =~ m/\G\s*$column_ident\s*(?>,|\Z)/gcxo) {
3414
my ($db_tbl_col, $as, $alias) = ($1, $2, $3); # XXX
3415
my $ident_struct = $self->parse_identifier('column', $db_tbl_col);
3416
$alias =~ s/`//g if $alias;
3417
my $col_struct = {
3418
%$ident_struct,
3419
($as ? (explicit_alias => 1) : ()),
3420
($alias ? (alias => $alias) : ()),
3421
};
3422
push @cols, $col_struct;
3423
}
3424
else {
3425
die "Column ident match failed"; # shouldn't happen
3426
}
3427
}
3428
3429
return \@cols;
3430
}
3431
3432
sub remove_subqueries {
3433
my ( $self, $query ) = @_;
3434
3435
my @start_pos;
3436
while ( $query =~ m/(\(SELECT )/gi ) {
3437
my $pos = (pos $query) - (length $1);
3438
push @start_pos, $pos;
3439
}
3440
3441
@start_pos = reverse @start_pos;
3442
my @end_pos;
3443
for my $i ( 0..$#start_pos ) {
3444
my $closed = 0;
3445
pos $query = $start_pos[$i];
3446
while ( $query =~ m/([\(\)])/cg ) {
3447
my $c = $1;
3448
$closed += ($c eq '(' ? 1 : -1);
3449
last unless $closed;
3450
}
3451
push @end_pos, pos $query;
3452
}
3453
3454
my @subqueries;
3455
my $len_adj = 0;
3456
my $n = 0;
3457
for my $i ( 0..$#start_pos ) {
3458
MKDEBUG && _d('Query:', $query);
3459
my $offset = $start_pos[$i];
3460
my $len = $end_pos[$i] - $start_pos[$i] - $len_adj;
3461
MKDEBUG && _d("Subquery $n start", $start_pos[$i],
3462
'orig end', $end_pos[$i], 'adj', $len_adj, 'adj end',
3463
$offset + $len, 'len', $len);
3464
3465
my $struct = {};
3466
my $token = '__SQ' . $n . '__';
3467
my $subquery = substr($query, $offset, $len, $token);
3468
MKDEBUG && _d("Subquery $n:", $subquery);
3469
3470
my $outer_start = $start_pos[$i + 1];
3471
my $outer_end = $end_pos[$i + 1];
3472
if ( $outer_start && ($outer_start < $start_pos[$i])
3473
&& $outer_end && ($outer_end > $end_pos[$i]) ) {
3474
MKDEBUG && _d("Subquery $n nested in next subquery");
3475
$len_adj += $len - length $token;
3476
$struct->{nested} = $i + 1;
3477
}
3478
else {
3479
MKDEBUG && _d("Subquery $n not nested");
3480
$len_adj = 0;
3481
if ( $subqueries[-1] && $subqueries[-1]->{nested} ) {
3482
MKDEBUG && _d("Outermost subquery");
3483
}
3484
}
3485
3486
if ( $query =~ m/(?:=|>|<|>=|<=|<>|!=|<=>)\s*$token/ ) {
3487
$struct->{context} = 'scalar';
3488
}
3489
elsif ( $query =~ m/\b(?:IN|ANY|SOME|ALL|EXISTS)\s*$token/i ) {
3490
if ( $query !~ m/\($token\)/ ) {
3491
$query =~ s/$token/\($token\)/;
3492
$len_adj -= 2 if $struct->{nested};
3493
}
3494
$struct->{context} = 'list';
3495
}
3496
else {
3497
$struct->{context} = 'identifier';
3498
}
3499
MKDEBUG && _d("Subquery $n context:", $struct->{context});
3500
3501
$subquery =~ s/^\s*\(//;
3502
$subquery =~ s/\s*\)\s*$//;
3503
3504
$struct->{query} = $subquery;
3505
push @subqueries, $struct;
3506
$n++;
3507
}
3508
3509
return $query, @subqueries;
3510
}
3511
3512
sub parse_identifiers {
3513
my ( $self, $idents ) = @_;
3514
return unless $idents;
3515
MKDEBUG && _d("Parsing identifiers");
3516
3517
my @ident_parts;
3518
foreach my $ident ( @$idents ) {
3519
MKDEBUG && _d("Identifier:", $ident);
3520
my $parts = {};
3521
3522
if ( $ident =~ s/\s+(ASC|DESC)\s*$//i ) {
3523
$parts->{sort} = uc $1; # XXX
3524
}
3525
3526
if ( $ident =~ m/^\d+$/ ) { # Position like 5
3527
MKDEBUG && _d("Positional ident");
3528
$parts->{position} = $ident;
3529
}
3530
elsif ( $ident =~ m/^\w+\(/ ) { # Function like MIN(col)
3531
MKDEBUG && _d("Expression ident");
3532
my ($func, $expr) = $ident =~ m/^(\w+)\(([^\)]*)\)/;
3533
$parts->{function} = uc $func;
3534
$parts->{expression} = $expr if $expr;
3535
}
3536
else { # Ref like (table.)column
3537
MKDEBUG && _d("Table/column ident");
3538
my ($tbl, $col) = $self->split_unquote($ident);
3539
$parts->{table} = $tbl if $tbl;
3540
$parts->{column} = $col;
3541
}
3542
push @ident_parts, $parts;
3543
}
3544
3545
return \@ident_parts;
3546
}
3547
3548
sub parse_identifier {
3549
my ( $self, $type, $ident ) = @_;
3550
return unless $type && $ident;
3551
MKDEBUG && _d("Parsing", $type, "identifier:", $ident);
3552
3553
my %ident_struct;
3554
my @ident_parts = map { s/`//g; $_; } split /[.]/, $ident;
3555
if ( @ident_parts == 3 ) {
3556
@ident_struct{qw(db tbl col)} = @ident_parts;
3557
}
3558
elsif ( @ident_parts == 2 ) {
3559
my @parts_for_type = $type eq 'column' ? qw(tbl col)
3560
: $type eq 'table' ? qw(db tbl)
3561
: die "Invalid identifier type: $type";
3562
@ident_struct{@parts_for_type} = @ident_parts;
3563
}
3564
elsif ( @ident_parts == 1 ) {
3565
my $part = $type eq 'column' ? 'col' : 'tbl';
3566
@ident_struct{($part)} = @ident_parts;
3567
}
3568
else {
3569
die "Invalid number of parts in $type reference: $ident";
3570
}
3571
3572
if ( $self->{SchemaQualifier} ) {
3573
if ( $type eq 'column' && !$ident_struct{tbl} ) {
3574
my $qcol = $self->{SchemaQualifier}->qualify_column(
3575
column => $ident_struct{col},
3576
);
3577
$ident_struct{db} = $qcol->{db} if $qcol->{db};
3578
$ident_struct{tbl} = $qcol->{tbl} if $qcol->{tbl};
3579
}
3580
elsif ( $type eq 'table' && !$ident_struct{db} ) {
3581
my $db = $self->{SchemaQualifier}->get_database_for_table(
3582
table => $ident_struct{tbl},
3583
);
3584
$ident_struct{db} = $db if $db;
3585
}
3586
}
3587
3588
MKDEBUG && _d($type, "identifier struct:", Dumper(\%ident_struct));
3589
return \%ident_struct;
3590
}
3591
3592
sub split_unquote {
3593
my ( $self, $db_tbl, $default_db ) = @_;
3594
$db_tbl =~ s/`//g;
3595
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
3596
if ( !$tbl ) {
3597
$tbl = $db;
3598
$db = $default_db;
3599
}
3600
return ($db, $tbl);
3601
}
3602
3603
sub is_identifier {
3604
my ( $self, $thing ) = @_;
3605
3606
return 0 unless $thing;
3607
3608
return 0 if $thing =~ m/\s*['"]/;
3609
3610
return 0 if $thing =~ m/^\s*\d+(?:\.\d+)?\s*$/;
3611
3612
return 0 if $thing =~ m/^\s*(?>
3613
NULL
3614
|DUAL
3615
)\s*$/xi;
3616
3617
return 1 if $thing =~ m/^\s*$column_ident\s*$/;
3618
3619
return 0;
3620
}
3621
3622
sub set_SchemaQualifier {
3623
my ( $self, $sq ) = @_;
3624
$self->{SchemaQualifier} = $sq;
3625
return;
3626
}
3627
3628
sub _d {
3629
my ($package, undef, $line) = caller 0;
3630
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3631
map { defined $_ ? $_ : 'undef' }
3632
@_;
3633
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3634
}
3635
3636
} # package scope
3637
1;
3638
3639
# ###########################################################################
3640
# End SQLParser package
3641
# ###########################################################################
3642
3643
# ###########################################################################
3644
# TableUsage package 7498
3645
# This package is a copy without comments from the original. The original
3646
# with comments and its test file can be found in the SVN repository at,
3647
# trunk/common/TableUsage.pm
3648
# trunk/common/t/TableUsage.t
3649
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
3650
# ###########################################################################
3651
3652
package TableUsage;
3653
3654
{ # package scope
3655
use strict;
3656
use warnings FATAL => 'all';
3657
use English qw(-no_match_vars);
3658
3659
use Data::Dumper;
3660
$Data::Dumper::Indent = 1;
3661
$Data::Dumper::Sortkeys = 1;
3662
$Data::Dumper::Quotekeys = 0;
3663
3664
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
3665
3666
sub new {
3667
my ( $class, %args ) = @_;
3668
my @required_args = qw(QueryParser SQLParser);
3669
foreach my $arg ( @required_args ) {
3670
die "I need a $arg argument" unless $args{$arg};
3671
}
3672
3673
my $self = {
3674
constant_data_value => 'DUAL',
3675
3676
%args,
3677
};
3678
3679
return bless $self, $class;
3680
}
3681
3682
sub get_table_usage {
3683
my ( $self, %args ) = @_;
3684
my @required_args = qw(query);
3685
foreach my $arg ( @required_args ) {
3686
die "I need a $arg argument" unless $args{$arg};
3687
}
3688
my ($query) = @args{@required_args};
3689
MKDEBUG && _d('Getting table access for',
3690
substr($query, 0, 100), (length $query > 100 ? '...' : ''));
3691
3692
my $cats; # arrayref of CAT hashrefs for each table
3693
3694
my $query_struct;
3695
eval {
3696
$query_struct = $self->{SQLParser}->parse($query);
3697
};
3698
if ( $EVAL_ERROR ) {
3699
MKDEBUG && _d('Failed to parse query with SQLParser:', $EVAL_ERROR);
3700
if ( $EVAL_ERROR =~ m/Cannot parse/ ) {
3701
$cats = $self->_get_tables_used_from_query_parser(%args);
3702
}
3703
else {
3704
die $EVAL_ERROR;
3705
}
3706
}
3707
else {
3708
$cats = $self->_get_tables_used_from_query_struct(
3709
query_struct => $query_struct,
3710
%args,
3711
);
3712
}
3713
3714
MKDEBUG && _d('Query table access:', Dumper($cats));
3715
return $cats;
3716
}
3717
3718
sub _get_tables_used_from_query_parser {
3719
my ( $self, %args ) = @_;
3720
my @required_args = qw(query);
3721
foreach my $arg ( @required_args ) {
3722
die "I need a $arg argument" unless $args{$arg};
3723
}
3724
my ($query) = @args{@required_args};
3725
MKDEBUG && _d('Getting tables used from query parser');
3726
3727
$query = $self->{QueryParser}->clean_query($query);
3728
my ($query_type) = $query =~ m/^\s*(\w+)\s+/;
3729
$query_type = uc $query_type;
3730
die "Query does not begin with a word" unless $query_type; # shouldn't happen
3731
3732
if ( $query_type eq 'DROP' ) {
3733
my ($drop_what) = $query =~ m/^\s*DROP\s+(\w+)\s+/i;
3734
die "Invalid DROP query: $query" unless $drop_what;
3735
$query_type .= '_' . uc($drop_what);
3736
}
3737
3738
my @tables_used;
3739
foreach my $table ( $self->{QueryParser}->get_tables($query) ) {
3740
$table =~ s/`//g;
3741
push @{$tables_used[0]}, {
3742
table => $table,
3743
context => $query_type,
3744
};
3745
}
3746
3747
return \@tables_used;
3748
}
3749
3750
sub _get_tables_used_from_query_struct {
3751
my ( $self, %args ) = @_;
3752
my @required_args = qw(query_struct);
3753
foreach my $arg ( @required_args ) {
3754
die "I need a $arg argument" unless $args{$arg};
3755
}
3756
my ($query_struct) = @args{@required_args};
3757
my $sp = $self->{SQLParser};
3758
3759
MKDEBUG && _d('Getting table used from query struct');
3760
3761
my $query_type = uc $query_struct->{type};
3762
my $tbl_refs = $query_type =~ m/(?:SELECT|DELETE)/ ? 'from'
3763
: $query_type =~ m/(?:INSERT|REPLACE)/ ? 'into'
3764
: $query_type =~ m/UPDATE/ ? 'tables'
3765
: die "Cannot find table references for $query_type queries";
3766
my $tables = $query_struct->{$tbl_refs};
3767
3768
if ( !$tables || @$tables == 0 ) {
3769
MKDEBUG && _d("Query does not use any tables");
3770
return [
3771
[ { context => $query_type, table => $self->{constant_data_value} } ]
3772
];
3773
}
3774
3775
my $where;
3776
if ( $query_struct->{where} ) {
3777
$where = $self->_get_tables_used_in_where(
3778
%args,
3779
tables => $tables,
3780
where => $query_struct->{where},
3781
);
3782
}
3783
3784
my @tables_used;
3785
if ( $query_type eq 'UPDATE' && @{$query_struct->{tables}} > 1 ) {
3786
MKDEBUG && _d("Multi-table UPDATE");
3787
3788
my @join_tables;
3789
foreach my $table ( @$tables ) {
3790
my $table = $self->_qualify_table_name(
3791
%args,
3792
tables => $tables,
3793
db => $table->{db},
3794
tbl => $table->{tbl},
3795
);
3796
my $table_usage = {
3797
context => 'JOIN',
3798
table => $table,
3799
};
3800
MKDEBUG && _d("Table usage from TLIST:", Dumper($table_usage));
3801
push @join_tables, $table_usage;
3802
}
3803
if ( $where && $where->{joined_tables} ) {
3804
foreach my $table ( @{$where->{joined_tables}} ) {
3805
my $table_usage = {
3806
context => $query_type,
3807
table => $table,
3808
};
3809
MKDEBUG && _d("Table usage from WHERE (implicit join):",
3810
Dumper($table_usage));
3811
push @join_tables, $table_usage;
3812
}
3813
}
3814
3815
my @where_tables;
3816
if ( $where && $where->{filter_tables} ) {
3817
foreach my $table ( @{$where->{filter_tables}} ) {
3818
my $table_usage = {
3819
context => 'WHERE',
3820
table => $table,
3821
};
3822
MKDEBUG && _d("Table usage from WHERE:", Dumper($table_usage));
3823
push @where_tables, $table_usage;
3824
}
3825
}
3826
3827
my $set_tables = $self->_get_tables_used_in_set(
3828
%args,
3829
tables => $tables,
3830
set => $query_struct->{set},
3831
);
3832
foreach my $table ( @$set_tables ) {
3833
my @table_usage = (
3834
{ # the written table
3835
context => 'UPDATE',
3836
table => $table->{table},
3837
},
3838
{ # source of data written to the written table
3839
context => 'SELECT',
3840
table => $table->{value},
3841
},
3842
);
3843
MKDEBUG && _d("Table usage from UPDATE SET:", Dumper(\@table_usage));
3844
push @tables_used, [
3845
@table_usage,
3846
@join_tables,
3847
@where_tables,
3848
];
3849
}
3850
} # multi-table UPDATE
3851
else {
3852
if ( $query_type eq 'SELECT' ) {
3853
my $clist_tables = $self->_get_tables_used_in_columns(
3854
%args,
3855
tables => $tables,
3856
columns => $query_struct->{columns},
3857
);
3858
foreach my $table ( @$clist_tables ) {
3859
my $table_usage = {
3860
context => 'SELECT',
3861
table => $table,
3862
};
3863
MKDEBUG && _d("Table usage from CLIST:", Dumper($table_usage));
3864
push @{$tables_used[0]}, $table_usage;
3865
}
3866
}
3867
3868
if ( @$tables > 1 || $query_type ne 'SELECT' ) {
3869
my $default_context = @$tables > 1 ? 'TLIST' : $query_type;
3870
foreach my $table ( @$tables ) {
3871
my $qualified_table = $self->_qualify_table_name(
3872
%args,
3873
tables => $tables,
3874
db => $table->{db},
3875
tbl => $table->{tbl},
3876
);
3877
3878
my $context = $default_context;
3879
if ( $table->{join} && $table->{join}->{condition} ) {
3880
$context = 'JOIN';
3881
if ( $table->{join}->{condition} eq 'using' ) {
3882
MKDEBUG && _d("Table joined with USING condition");
3883
my $joined_table = $self->_qualify_table_name(
3884
%args,
3885
tables => $tables,
3886
tbl => $table->{join}->{to},
3887
);
3888
$self->_change_context(
3889
tables => $tables,
3890
table => $joined_table,
3891
tables_used => $tables_used[0],
3892
old_context => 'TLIST',
3893
new_context => 'JOIN',
3894
);
3895
}
3896
elsif ( $table->{join}->{condition} eq 'on' ) {
3897
MKDEBUG && _d("Table joined with ON condition");
3898
my $on_tables = $self->_get_tables_used_in_where(
3899
%args,
3900
tables => $tables,
3901
where => $table->{join}->{where},
3902
clause => 'JOIN condition', # just for debugging
3903
);
3904
MKDEBUG && _d("JOIN ON tables:", Dumper($on_tables));
3905
foreach my $joined_table ( @{$on_tables->{joined_tables}} ) {
3906
$self->_change_context(
3907
tables => $tables,
3908
table => $joined_table,
3909
tables_used => $tables_used[0],
3910
old_context => 'TLIST',
3911
new_context => 'JOIN',
3912
);
3913
}
3914
}
3915
else {
3916
warn "Unknown JOIN condition: $table->{join}->{condition}";
3917
}
3918
}
3919
3920
my $table_usage = {
3921
context => $context,
3922
table => $qualified_table,
3923
};
3924
MKDEBUG && _d("Table usage from TLIST:", Dumper($table_usage));
3925
push @{$tables_used[0]}, $table_usage;
3926
}
3927
}
3928
3929
if ( $where && $where->{joined_tables} ) {
3930
foreach my $joined_table ( @{$where->{joined_tables}} ) {
3931
MKDEBUG && _d("Table joined implicitly in WHERE:", $joined_table);
3932
$self->_change_context(
3933
tables => $tables,
3934
table => $joined_table,
3935
tables_used => $tables_used[0],
3936
old_context => 'TLIST',
3937
new_context => 'JOIN',
3938
);
3939
}
3940
}
3941
3942
if ( $query_type =~ m/(?:INSERT|REPLACE)/ ) {
3943
if ( $query_struct->{select} ) {
3944
MKDEBUG && _d("Getting tables used in INSERT-SELECT");
3945
my $select_tables = $self->_get_tables_used_from_query_struct(
3946
%args,
3947
query_struct => $query_struct->{select},
3948
);
3949
push @{$tables_used[0]}, @{$select_tables->[0]};
3950
}
3951
else {
3952
my $table_usage = {
3953
context => 'SELECT',
3954
table => $self->{constant_data_value},
3955
};
3956
MKDEBUG && _d("Table usage from SET/VALUES:", Dumper($table_usage));
3957
push @{$tables_used[0]}, $table_usage;
3958
}
3959
}
3960
elsif ( $query_type eq 'UPDATE' ) {
3961
my $set_tables = $self->_get_tables_used_in_set(
3962
%args,
3963
tables => $tables,
3964
set => $query_struct->{set},
3965
);
3966
foreach my $table ( @$set_tables ) {
3967
my $table_usage = {
3968
context => 'SELECT',
3969
table => $table->{value_is_table} ? $table->{table}
3970
: $self->{constant_data_value},
3971
};
3972
MKDEBUG && _d("Table usage from SET:", Dumper($table_usage));
3973
push @{$tables_used[0]}, $table_usage;
3974
}
3975
}
3976
3977
if ( $where && $where->{filter_tables} ) {
3978
foreach my $table ( @{$where->{filter_tables}} ) {
3979
my $table_usage = {
3980
context => 'WHERE',
3981
table => $table,
3982
};
3983
MKDEBUG && _d("Table usage from WHERE:", Dumper($table_usage));
3984
push @{$tables_used[0]}, $table_usage;
3985
}
3986
}
3987
}
3988
3989
return \@tables_used;
3990
}
3991
3992
sub _get_tables_used_in_columns {
3993
my ( $self, %args ) = @_;
3994
my @required_args = qw(tables columns);
3995
foreach my $arg ( @required_args ) {
3996
die "I need a $arg argument" unless $args{$arg};
3997
}
3998
my ($tables, $columns) = @args{@required_args};
3999
4000
MKDEBUG && _d("Getting tables used in CLIST");
4001
my @tables;
4002
4003
if ( @$tables == 1 ) {
4004
MKDEBUG && _d("Single table SELECT:", $tables->[0]->{tbl});
4005
my $table = $self->_qualify_table_name(
4006
%args,
4007
db => $tables->[0]->{db},
4008
tbl => $tables->[0]->{tbl},
4009
);
4010
@tables = ($table);
4011
}
4012
elsif ( @$columns == 1 && $columns->[0]->{col} eq '*' ) {
4013
if ( $columns->[0]->{tbl} ) {
4014
MKDEBUG && _d("SELECT all columns from one table");
4015
my $table = $self->_qualify_table_name(
4016
%args,
4017
db => $columns->[0]->{db},
4018
tbl => $columns->[0]->{tbl},
4019
);
4020
@tables = ($table);
4021
}
4022
else {
4023
MKDEBUG && _d("SELECT all columns from all tables");
4024
foreach my $table ( @$tables ) {
4025
my $table = $self->_qualify_table_name(
4026
%args,
4027
tables => $tables,
4028
db => $table->{db},
4029
tbl => $table->{tbl},
4030
);
4031
push @tables, $table;
4032
}
4033
}
4034
}
4035
else {
4036
MKDEBUG && _d(scalar @$tables, "table SELECT");
4037
my %seen;
4038
COLUMN:
4039
foreach my $column ( @$columns ) {
4040
next COLUMN unless $column->{tbl};
4041
my $table = $self->_qualify_table_name(
4042
%args,
4043
db => $column->{db},
4044
tbl => $column->{tbl},
4045
);
4046
push @tables, $table if $table && !$seen{$table}++;
4047
}
4048
}
4049
4050
return \@tables;
4051
}
4052
4053
sub _get_tables_used_in_where {
4054
my ( $self, %args ) = @_;
4055
my @required_args = qw(tables where);
4056
foreach my $arg ( @required_args ) {
4057
die "I need a $arg argument" unless $args{$arg};
4058
}
4059
my ($tables, $where) = @args{@required_args};
4060
my $sql_parser = $self->{SQLParser};
4061
4062
MKDEBUG && _d("Getting tables used in", $args{clause} || 'WHERE');
4063
4064
my %filter_tables;
4065
my %join_tables;
4066
CONDITION:
4067
foreach my $cond ( @$where ) {
4068
MKDEBUG && _d("Condition:", Dumper($cond));
4069
my @tables; # tables used in this condition
4070
my $n_vals = 0;
4071
my $is_constant = 0;
4072
my $unknown_table = 0;
4073
ARG:
4074
foreach my $arg ( qw(left_arg right_arg) ) {
4075
if ( !defined $cond->{$arg} ) {
4076
MKDEBUG && _d($arg, "is a constant value");
4077
$is_constant = 1;
4078
next ARG;
4079
}
4080
4081
if ( $sql_parser->is_identifier($cond->{$arg}) ) {
4082
MKDEBUG && _d($arg, "is an identifier");
4083
my $ident_struct = $sql_parser->parse_identifier(
4084
'column',
4085
$cond->{$arg}
4086
);
4087
4088
if ( !$ident_struct->{tbl} ) {
4089
if ( @$tables == 1 ) {
4090
MKDEBUG && _d("Condition column is not table-qualified; ",
4091
"using query's only table:", $tables->[0]->{tbl});
4092
$ident_struct->{tbl} = $tables->[0]->{tbl};
4093
}
4094
else {
4095
MKDEBUG && _d("Condition column is not table-qualified and",
4096
"query has multiple tables; cannot determine its table");
4097
if ( $cond->{$arg} !~ m/\w+\(/ # not a function
4098
&& $cond->{$arg} !~ m/^[\d.]+$/) { # not a number
4099
$unknown_table = 1;
4100
}
4101
next ARG;
4102
}
4103
}
4104
4105
if ( !$ident_struct->{db} && @$tables == 1 && $tables->[0]->{db} ) {
4106
MKDEBUG && _d("Condition column is not database-qualified; ",
4107
"using its table's database:", $tables->[0]->{db});
4108
$ident_struct->{db} = $tables->[0]->{db};
4109
}
4110
4111
my $table = $self->_qualify_table_name(
4112
%args,
4113
%$ident_struct,
4114
);
4115
if ( $table ) {
4116
push @tables, $table;
4117
}
4118
}
4119
else {
4120
MKDEBUG && _d($arg, "is a value");
4121
$n_vals++;
4122
}
4123
} # ARG
4124
4125
if ( $is_constant || $n_vals == 2 ) {
4126
MKDEBUG && _d("Condition is a constant or two values");
4127
$filter_tables{$self->{constant_data_value}} = undef;
4128
}
4129
else {
4130
if ( @tables == 1 ) {
4131
if ( $unknown_table ) {
4132
MKDEBUG && _d("Condition joins table",
4133
$tables[0], "to column from unknown table");
4134
$join_tables{$tables[0]} = undef;
4135
}
4136
else {
4137
MKDEBUG && _d("Condition filters table", $tables[0]);
4138
$filter_tables{$tables[0]} = undef;
4139
}
4140
}
4141
elsif ( @tables == 2 ) {
4142
MKDEBUG && _d("Condition joins tables",
4143
$tables[0], "and", $tables[1]);
4144
$join_tables{$tables[0]} = undef;
4145
$join_tables{$tables[1]} = undef;
4146
}
4147
}
4148
} # CONDITION
4149
4150
return {
4151
filter_tables => [ sort keys %filter_tables ],
4152
joined_tables => [ sort keys %join_tables ],
4153
};
4154
}
4155
4156
sub _get_tables_used_in_set {
4157
my ( $self, %args ) = @_;
4158
my @required_args = qw(tables set);
4159
foreach my $arg ( @required_args ) {
4160
die "I need a $arg argument" unless $args{$arg};
4161
}
4162
my ($tables, $set) = @args{@required_args};
4163
my $sql_parser = $self->{SQLParser};
4164
4165
MKDEBUG && _d("Getting tables used in SET");
4166
4167
my @tables;
4168
if ( @$tables == 1 ) {
4169
my $table = $self->_qualify_table_name(
4170
%args,
4171
db => $tables->[0]->{db},
4172
tbl => $tables->[0]->{tbl},
4173
);
4174
$tables[0] = {
4175
table => $table,
4176
value => $self->{constant_data_value}
4177
};
4178
}
4179
else {
4180
foreach my $cond ( @$set ) {
4181
next unless $cond->{tbl};
4182
my $table = $self->_qualify_table_name(
4183
%args,
4184
db => $cond->{db},
4185
tbl => $cond->{tbl},
4186
);
4187
4188
my $value = $self->{constant_data_value};
4189
my $value_is_table = 0;
4190
if ( $sql_parser->is_identifier($cond->{value}) ) {
4191
my $ident_struct = $sql_parser->parse_identifier(
4192
'column',
4193
$cond->{value},
4194
);
4195
$value_is_table = 1;
4196
$value = $self->_qualify_table_name(
4197
%args,
4198
db => $ident_struct->{db},
4199
tbl => $ident_struct->{tbl},
4200
);
4201
}
4202
4203
push @tables, {
4204
table => $table,
4205
value => $value,
4206
value_is_table => $value_is_table,
4207
};
4208
}
4209
}
4210
4211
return \@tables;
4212
}
4213
4214
sub _get_real_table_name {
4215
my ( $self, %args ) = @_;
4216
my @required_args = qw(tables name);
4217
foreach my $arg ( @required_args ) {
4218
die "I need a $arg argument" unless $args{$arg};
4219
}
4220
my ($tables, $name) = @args{@required_args};
4221
4222
foreach my $table ( @$tables ) {
4223
if ( $table->{tbl} eq $name
4224
|| ($table->{alias} || "") eq $name ) {
4225
MKDEBUG && _d("Real table name for", $name, "is", $table->{tbl});
4226
return $table->{tbl};
4227
}
4228
}
4229
MKDEBUG && _d("Table", $name, "does not exist in query");
4230
return;
4231
}
4232
4233
sub _qualify_table_name {
4234
my ( $self, %args) = @_;
4235
my @required_args = qw(tables tbl);
4236
foreach my $arg ( @required_args ) {
4237
die "I need a $arg argument" unless $args{$arg};
4238
}
4239
my ($tables, $table) = @args{@required_args};
4240
4241
MKDEBUG && _d("Qualifying table with database:", $table);
4242
4243
my ($tbl, $db) = reverse split /[.]/, $table;
4244
4245
$tbl = $self->_get_real_table_name(%args, name => $tbl);
4246
return unless $tbl; # shouldn't happen
4247
4248
my $db_tbl;
4249
4250
if ( $db ) {
4251
$db_tbl = "$db.$tbl";
4252
}
4253
elsif ( $args{db} ) {
4254
$db_tbl = "$args{db}.$tbl";
4255
}
4256
else {
4257
foreach my $tbl_info ( @$tables ) {
4258
if ( ($tbl_info->{tbl} eq $tbl) && $tbl_info->{db} ) {
4259
$db_tbl = "$tbl_info->{db}.$tbl";
4260
last;
4261
}
4262
}
4263
4264
if ( !$db_tbl && $args{default_db} ) {
4265
$db_tbl = "$args{default_db}.$tbl";
4266
}
4267
4268
if ( !$db_tbl ) {
4269
MKDEBUG && _d("Cannot determine database for table", $tbl);
4270
$db_tbl = $tbl;
4271
}
4272
}
4273
4274
MKDEBUG && _d("Table qualified with database:", $db_tbl);
4275
return $db_tbl;
4276
}
4277
4278
sub _change_context {
4279
my ( $self, %args) = @_;
4280
my @required_args = qw(tables_used table old_context new_context tables);
4281
foreach my $arg ( @required_args ) {
4282
die "I need a $arg argument" unless $args{$arg};
4283
}
4284
my ($tables_used, $table, $old_context, $new_context) = @args{@required_args};
4285
MKDEBUG && _d("Change context of table", $table, "from", $old_context,
4286
"to", $new_context);
4287
foreach my $used_table ( @$tables_used ) {
4288
if ( $used_table->{table} eq $table
4289
&& $used_table->{context} eq $old_context ) {
4290
$used_table->{context} = $new_context;
4291
return;
4292
}
4293
}
4294
MKDEBUG && _d("Table", $table, "is not used; cannot set its context");
4295
return;
4296
}
4297
4298
sub _d {
4299
my ($package, undef, $line) = caller 0;
4300
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4301
map { defined $_ ? $_ : 'undef' }
4302
@_;
4303
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4304
}
4305
4306
} # package scope
4307
1;
4308
4309
# ###########################################################################
4310
# End TableUsage package
4311
# ###########################################################################
4312
4313
# ###########################################################################
4314
# Daemon package 6255
4315
# This package is a copy without comments from the original. The original
4316
# with comments and its test file can be found in the SVN repository at,
4317
# trunk/common/Daemon.pm
4318
# trunk/common/t/Daemon.t
4319
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
4320
# ###########################################################################
4321
4322
package Daemon;
4323
4324
use strict;
4325
use warnings FATAL => 'all';
4326
4327
use POSIX qw(setsid);
4328
use English qw(-no_match_vars);
4329
4330
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
4331
4332
sub new {
4333
my ( $class, %args ) = @_;
4334
foreach my $arg ( qw(o) ) {
4335
die "I need a $arg argument" unless $args{$arg};
4336
}
4337
my $o = $args{o};
4338
my $self = {
4339
o => $o,
4340
log_file => $o->has('log') ? $o->get('log') : undef,
4341
PID_file => $o->has('pid') ? $o->get('pid') : undef,
4342
};
4343
4344
check_PID_file(undef, $self->{PID_file});
4345
4346
MKDEBUG && _d('Daemonized child will log to', $self->{log_file});
4347
return bless $self, $class;
4348
}
4349
4350
sub daemonize {
4351
my ( $self ) = @_;
4352
4353
MKDEBUG && _d('About to fork and daemonize');
4354
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
4355
if ( $pid ) {
4356
MKDEBUG && _d('I am the parent and now I die');
4357
exit;
4358
}
4359
4360
$self->{PID_owner} = $PID;
4361
$self->{child} = 1;
4362
4363
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
4364
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
4365
4366
$self->_make_PID_file();
4367
4368
$OUTPUT_AUTOFLUSH = 1;
4369
4370
if ( -t STDIN ) {
4371
close STDIN;
4372
open STDIN, '/dev/null'
4373
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
4374
}
4375
4376
if ( $self->{log_file} ) {
4377
close STDOUT;
4378
open STDOUT, '>>', $self->{log_file}
4379
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
4380
4381
close STDERR;
4382
open STDERR, ">&STDOUT"
4383
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
4384
}
4385
else {
4386
if ( -t STDOUT ) {
4387
close STDOUT;
4388
open STDOUT, '>', '/dev/null'
4389
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
4390
}
4391
if ( -t STDERR ) {
4392
close STDERR;
4393
open STDERR, '>', '/dev/null'
4394
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
4395
}
4396
}
4397
4398
MKDEBUG && _d('I am the child and now I live daemonized');
4399
return;
4400
}
4401
4402
sub check_PID_file {
4403
my ( $self, $file ) = @_;
4404
my $PID_file = $self ? $self->{PID_file} : $file;
4405
MKDEBUG && _d('Checking PID file', $PID_file);
4406
if ( $PID_file && -f $PID_file ) {
4407
my $pid;
4408
eval { chomp($pid = `cat $PID_file`); };
4409
die "Cannot cat $PID_file: $OS_ERROR" if $EVAL_ERROR;
4410
MKDEBUG && _d('PID file exists; it contains PID', $pid);
4411
if ( $pid ) {
4412
my $pid_is_alive = kill 0, $pid;
4413
if ( $pid_is_alive ) {
4414
die "The PID file $PID_file already exists "
4415
. " and the PID that it contains, $pid, is running";
4416
}
4417
else {
4418
warn "Overwriting PID file $PID_file because the PID that it "
4419
. "contains, $pid, is not running";
4420
}
4421
}
4422
else {
4423
die "The PID file $PID_file already exists but it does not "
4424
. "contain a PID";
4425
}
4426
}
4427
else {
4428
MKDEBUG && _d('No PID file');
4429
}
4430
return;
4431
}
4432
4433
sub make_PID_file {
4434
my ( $self ) = @_;
4435
if ( exists $self->{child} ) {
4436
die "Do not call Daemon::make_PID_file() for daemonized scripts";
4437
}
4438
$self->_make_PID_file();
4439
$self->{PID_owner} = $PID;
4440
return;
4441
}
4442
4443
sub _make_PID_file {
4444
my ( $self ) = @_;
4445
4446
my $PID_file = $self->{PID_file};
4447
if ( !$PID_file ) {
4448
MKDEBUG && _d('No PID file to create');
4449
return;
4450
}
4451
4452
$self->check_PID_file();
4453
4454
open my $PID_FH, '>', $PID_file
4455
or die "Cannot open PID file $PID_file: $OS_ERROR";
4456
print $PID_FH $PID
4457
or die "Cannot print to PID file $PID_file: $OS_ERROR";
4458
close $PID_FH
4459
or die "Cannot close PID file $PID_file: $OS_ERROR";
4460
4461
MKDEBUG && _d('Created PID file:', $self->{PID_file});
4462
return;
4463
}
4464
4465
sub _remove_PID_file {
4466
my ( $self ) = @_;
4467
if ( $self->{PID_file} && -f $self->{PID_file} ) {
4468
unlink $self->{PID_file}
4469
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
4470
MKDEBUG && _d('Removed PID file');
4471
}
4472
else {
4473
MKDEBUG && _d('No PID to remove');
4474
}
4475
return;
4476
}
4477
4478
sub DESTROY {
4479
my ( $self ) = @_;
4480
4481
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
4482
4483
return;
4484
}
4485
4486
sub _d {
4487
my ($package, undef, $line) = caller 0;
4488
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4489
map { defined $_ ? $_ : 'undef' }
4490
@_;
4491
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4492
}
4493
4494
1;
4495
4496
# ###########################################################################
4497
# End Daemon package
4498
# ###########################################################################
4499
4500
# ###########################################################################
4501
# Runtime package 7221
4502
# This package is a copy without comments from the original. The original
4503
# with comments and its test file can be found in the SVN repository at,
4504
# trunk/common/Runtime.pm
4505
# trunk/common/t/Runtime.t
4506
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
4507
# ###########################################################################
4508
4509
package Runtime;
4510
4511
use strict;
4512
use warnings FATAL => 'all';
4513
use English qw(-no_match_vars);
4514
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
4515
4516
sub new {
4517
my ( $class, %args ) = @_;
4518
my @required_args = qw(now);
4519
foreach my $arg ( @required_args ) {
4520
die "I need a $arg argument" unless $args{$arg};
4521
}
4522
4523
if ( ($args{runtime} || 0) < 0 ) {
4524
die "runtime argument must be greater than zero"
4525
}
4526
4527
my $self = {
4528
%args,
4529
start_time => undef,
4530
end_time => undef,
4531
time_left => undef,
4532
stop => 0,
4533
};
4534
4535
return bless $self, $class;
4536
}
4537
4538
sub time_left {
4539
my ( $self, %args ) = @_;
4540
4541
if ( $self->{stop} ) {
4542
MKDEBUG && _d("No time left because stop was called");
4543
return 0;
4544
}
4545
4546
my $now = $self->{now}->(%args);
4547
MKDEBUG && _d("Current time:", $now);
4548
4549
if ( !defined $self->{start_time} ) {
4550
$self->{start_time} = $now;
4551
}
4552
4553
return unless defined $now;
4554
4555
my $runtime = $self->{runtime};
4556
return unless defined $runtime;
4557
4558
if ( !$self->{end_time} ) {
4559
$self->{end_time} = $now + $runtime;
4560
MKDEBUG && _d("End time:", $self->{end_time});
4561
}
4562
4563
$self->{time_left} = $self->{end_time} - $now;
4564
MKDEBUG && _d("Time left:", $self->{time_left});
4565
return $self->{time_left};
4566
}
4567
4568
sub have_time {
4569
my ( $self, %args ) = @_;
4570
my $time_left = $self->time_left(%args);
4571
return 1 if !defined $time_left; # run forever
4572
return $time_left <= 0 ? 0 : 1; # <=0s means runtime has elapsed
4573
}
4574
4575
sub time_elapsed {
4576
my ( $self, %args ) = @_;
4577
4578
my $start_time = $self->{start_time};
4579
return 0 unless $start_time;
4580
4581
my $now = $self->{now}->(%args);
4582
MKDEBUG && _d("Current time:", $now);
4583
4584
my $time_elapsed = $now - $start_time;
4585
MKDEBUG && _d("Time elapsed:", $time_elapsed);
4586
if ( $time_elapsed < 0 ) {
4587
warn "Current time $now is earlier than start time $start_time";
4588
}
4589
return $time_elapsed;
4590
}
4591
4592
sub reset {
4593
my ( $self ) = @_;
4594
$self->{start_time} = undef;
4595
$self->{end_time} = undef;
4596
$self->{time_left} = undef;
4597
$self->{stop} = 0;
4598
MKDEBUG && _d("Reset runtime");
4599
return;
4600
}
4601
4602
sub stop {
4603
my ( $self ) = @_;
4604
$self->{stop} = 1;
4605
return;
4606
}
4607
4608
sub start {
4609
my ( $self ) = @_;
4610
$self->{stop} = 0;
4611
return;
4612
}
4613
4614
sub _d {
4615
my ($package, undef, $line) = caller 0;
4616
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4617
map { defined $_ ? $_ : 'undef' }
4618
@_;
4619
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4620
}
4621
4622
1;
4623
4624
# ###########################################################################
4625
# End Runtime package
4626
# ###########################################################################
4627
4628
# ###########################################################################
4629
# Progress package 7096
4630
# This package is a copy without comments from the original. The original
4631
# with comments and its test file can be found in the SVN repository at,
4632
# trunk/common/Progress.pm
4633
# trunk/common/t/Progress.t
4634
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
4635
# ###########################################################################
4636
package Progress;
4637
4638
use strict;
4639
use warnings FATAL => 'all';
4640
4641
use English qw(-no_match_vars);
4642
use Data::Dumper;
4643
$Data::Dumper::Indent = 1;
4644
$Data::Dumper::Sortkeys = 1;
4645
$Data::Dumper::Quotekeys = 0;
4646
4647
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
4648
4649
sub new {
4650
my ( $class, %args ) = @_;
4651
foreach my $arg (qw(jobsize)) {
4652
die "I need a $arg argument" unless defined $args{$arg};
4653
}
4654
if ( (!$args{report} || !$args{interval}) ) {
4655
if ( $args{spec} && @{$args{spec}} == 2 ) {
4656
@args{qw(report interval)} = @{$args{spec}};
4657
}
4658
else {
4659
die "I need either report and interval arguments, or a spec";
4660
}
4661
}
4662
4663
my $name = $args{name} || "Progress";
4664
$args{start} ||= time();
4665
my $self;
4666
$self = {
4667
last_reported => $args{start},
4668
fraction => 0, # How complete the job is
4669
callback => sub {
4670
my ($fraction, $elapsed, $remaining, $eta) = @_;
4671
printf STDERR "$name: %3d%% %s remain\n",
4672
$fraction * 100,
4673
Transformers::secs_to_time($remaining),
4674
Transformers::ts($eta);
4675
},
4676
%args,
4677
};
4678
return bless $self, $class;
4679
}
4680
4681
sub validate_spec {
4682
shift @_ if $_[0] eq 'Progress'; # Permit calling as Progress-> or Progress::
4683
my ( $spec ) = @_;
4684
if ( @$spec != 2 ) {
4685
die "spec array requires a two-part argument\n";
4686
}
4687
if ( $spec->[0] !~ m/^(?:percentage|time|iterations)$/ ) {
4688
die "spec array's first element must be one of "
4689
. "percentage,time,iterations\n";
4690
}
4691
if ( $spec->[1] !~ m/^\d+$/ ) {
4692
die "spec array's second element must be an integer\n";
4693
}
4694
}
4695
4696
sub set_callback {
4697
my ( $self, $callback ) = @_;
4698
$self->{callback} = $callback;
4699
}
4700
4701
sub start {
4702
my ( $self, $start ) = @_;
4703
$self->{start} = $self->{last_reported} = $start || time();
4704
}
4705
4706
sub update {
4707
my ( $self, $callback, $now ) = @_;
4708
my $jobsize = $self->{jobsize};
4709
$now ||= time();
4710
$self->{iterations}++; # How many updates have happened;
4711
4712
if ( $self->{report} eq 'time'
4713
&& $self->{interval} > $now - $self->{last_reported}
4714
) {
4715
return;
4716
}
4717
elsif ( $self->{report} eq 'iterations'
4718
&& ($self->{iterations} - 1) % $self->{interval} > 0
4719
) {
4720
return;
4721
}
4722
$self->{last_reported} = $now;
4723
4724
my $completed = $callback->();
4725
$self->{updates}++; # How many times we have run the update callback
4726
4727
return if $completed > $jobsize;
4728
4729
my $fraction = $completed > 0 ? $completed / $jobsize : 0;
4730
4731
if ( $self->{report} eq 'percentage'
4732
&& $self->fraction_modulo($self->{fraction})
4733
>= $self->fraction_modulo($fraction)
4734
) {
4735
$self->{fraction} = $fraction;
4736
return;
4737
}
4738
$self->{fraction} = $fraction;
4739
4740
my $elapsed = $now - $self->{start};
4741
my $remaining = 0;
4742
my $eta = $now;
4743
if ( $completed > 0 && $completed <= $jobsize && $elapsed > 0 ) {
4744
my $rate = $completed / $elapsed;
4745
if ( $rate > 0 ) {
4746
$remaining = ($jobsize - $completed) / $rate;
4747
$eta = $now + int($remaining);
4748
}
4749
}
4750
$self->{callback}->($fraction, $elapsed, $remaining, $eta, $completed);
4751
}
4752
4753
sub fraction_modulo {
4754
my ( $self, $num ) = @_;
4755
$num *= 100; # Convert from fraction to percentage
4756
return sprintf('%d',
4757
sprintf('%d', $num / $self->{interval}) * $self->{interval});
4758
}
4759
4760
sub _d {
4761
my ($package, undef, $line) = caller 0;
4762
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4763
map { defined $_ ? $_ : 'undef' }
4764
@_;
4765
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4766
}
4767
4768
1;
4769
4770
# ###########################################################################
4771
# End Progress package
4772
# ###########################################################################
4773
4774
# ###########################################################################
4775
# Pipeline package 7509
4776
# This package is a copy without comments from the original. The original
4777
# with comments and its test file can be found in the SVN repository at,
4778
# trunk/common/Pipeline.pm
4779
# trunk/common/t/Pipeline.t
4780
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
4781
# ###########################################################################
4782
4783
package Pipeline;
4784
4785
use strict;
4786
use warnings FATAL => 'all';
4787
use English qw(-no_match_vars);
4788
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
4789
4790
use Data::Dumper;
4791
$Data::Dumper::Indent = 1;
4792
$Data::Dumper::Sortkeys = 1;
4793
$Data::Dumper::Quotekeys = 0;
4794
use Time::HiRes qw(time);
4795
4796
sub new {
4797
my ( $class, %args ) = @_;
4798
my @required_args = qw();
4799
foreach my $arg ( @required_args ) {
4800
die "I need a $arg argument" unless defined $args{$arg};
4801
}
4802
4803
my $self = {
4804
instrument => 0,
4805
continue_on_error => 0,
4806
4807
%args,
4808
4809
procs => [], # coderefs for pipeline processes
4810
names => [], # names for each ^ pipeline proc
4811
instrumentation => { # keyed on proc index in procs
4812
Pipeline => {
4813
time => 0,
4814
calls => 0,
4815
},
4816
},
4817
};
4818
return bless $self, $class;
4819
}
4820
4821
sub add {
4822
my ( $self, %args ) = @_;
4823
my @required_args = qw(process name);
4824
foreach my $arg ( @required_args ) {
4825
die "I need a $arg argument" unless defined $args{$arg};
4826
}
4827
my ($process, $name) = @args{@required_args};
4828
4829
push @{$self->{procs}}, $process;
4830
push @{$self->{names}}, $name;
4831
if ( $self->{instrument} ) {
4832
$self->{instrumentation}->{$name} = { time => 0, calls => 0 };
4833
}
4834
MKDEBUG && _d("Added pipeline process", $name);
4835
4836
return;
4837
}
4838
4839
sub processes {
4840
my ( $self ) = @_;
4841
return @{$self->{names}};
4842
}
4843
4844
sub execute {
4845
my ( $self, %args ) = @_;
4846
4847
die "Cannot execute pipeline because no process have been added"
4848
unless scalar @{$self->{procs}};
4849
4850
my $oktorun = $args{oktorun};
4851
die "I need an oktorun argument" unless $oktorun;
4852
die '$oktorun argument must be a reference' unless ref $oktorun;
4853
4854
my $pipeline_data = $args{pipeline_data} || {};
4855
$pipeline_data->{oktorun} = $oktorun;
4856
4857
my $stats = $args{stats}; # optional
4858
4859
MKDEBUG && _d("Pipeline starting at", time);
4860
my $instrument = $self->{instrument};
4861
my $processes = $self->{procs};
4862
EVENT:
4863
while ( $$oktorun ) {
4864
my $procno = 0; # so we can see which proc if one causes an error
4865
my $output;
4866
eval {
4867
PIPELINE_PROCESS:
4868
while ( $procno < scalar @{$self->{procs}} ) {
4869
my $call_start = $instrument ? time : 0;
4870
4871
MKDEBUG && _d("Pipeline process", $self->{names}->[$procno]);
4872
$output = $processes->[$procno]->($pipeline_data);
4873
4874
if ( $instrument ) {
4875
my $call_end = time;
4876
my $call_t = $call_end - $call_start;
4877
$self->{instrumentation}->{$self->{names}->[$procno]}->{time} += $call_t;
4878
$self->{instrumentation}->{$self->{names}->[$procno]}->{count}++;
4879
$self->{instrumentation}->{Pipeline}->{time} += $call_t;
4880
$self->{instrumentation}->{Pipeline}->{count}++;
4881
}
4882
if ( !$output ) {
4883
MKDEBUG && _d("Pipeline restarting early after",
4884
$self->{names}->[$procno]);
4885
if ( $stats ) {
4886
$stats->{"pipeline_restarted_after_"
4887
.$self->{names}->[$procno]}++;
4888
}
4889
last PIPELINE_PROCESS;
4890
}
4891
$procno++;
4892
}
4893
};
4894
if ( $EVAL_ERROR ) {
4895
warn "Pipeline process $procno ("
4896
. ($self->{names}->[$procno] || "")
4897
. ") caused an error: $EVAL_ERROR";
4898
die $EVAL_ERROR unless $self->{continue_on_error};
4899
}
4900
}
4901
4902
MKDEBUG && _d("Pipeline stopped at", time);
4903
return;
4904
}
4905
4906
sub instrumentation {
4907
my ( $self ) = @_;
4908
return $self->{instrumentation};
4909
}
4910
4911
sub reset {
4912
my ( $self ) = @_;
4913
foreach my $proc_name ( @{$self->{names}} ) {
4914
if ( exists $self->{instrumentation}->{$proc_name} ) {
4915
$self->{instrumentation}->{$proc_name}->{calls} = 0;
4916
$self->{instrumentation}->{$proc_name}->{time} = 0;
4917
}
4918
}
4919
$self->{instrumentation}->{Pipeline}->{calls} = 0;
4920
$self->{instrumentation}->{Pipeline}->{time} = 0;
4921
return;
4922
}
4923
4924
sub _d {
4925
my ($package, undef, $line) = caller 0;
4926
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4927
map { defined $_ ? $_ : 'undef' }
4928
@_;
4929
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4930
}
4931
4932
1;
4933
4934
# ###########################################################################
4935
# End Pipeline package
4936
# ###########################################################################
4937
4938
# ###########################################################################
4939
# Quoter package 6850
4940
# This package is a copy without comments from the original. The original
4941
# with comments and its test file can be found in the SVN repository at,
4942
# trunk/common/Quoter.pm
4943
# trunk/common/t/Quoter.t
4944
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
4945
# ###########################################################################
4946
4947
package Quoter;
4948
4949
use strict;
4950
use warnings FATAL => 'all';
4951
use English qw(-no_match_vars);
4952
4953
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
4954
4955
sub new {
4956
my ( $class, %args ) = @_;
4957
return bless {}, $class;
4958
}
4959
4960
sub quote {
4961
my ( $self, @vals ) = @_;
4962
foreach my $val ( @vals ) {
4963
$val =~ s/`/``/g;
4964
}
4965
return join('.', map { '`' . $_ . '`' } @vals);
4966
}
4967
4968
sub quote_val {
4969
my ( $self, $val ) = @_;
4970
4971
return 'NULL' unless defined $val; # undef = NULL
4972
return "''" if $val eq ''; # blank string = ''
4973
return $val if $val =~ m/^0x[0-9a-fA-F]+$/; # hex data
4974
4975
$val =~ s/(['\\])/\\$1/g;
4976
return "'$val'";
4977
}
4978
4979
sub split_unquote {
4980
my ( $self, $db_tbl, $default_db ) = @_;
4981
$db_tbl =~ s/`//g;
4982
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
4983
if ( !$tbl ) {
4984
$tbl = $db;
4985
$db = $default_db;
4986
}
4987
return ($db, $tbl);
4988
}
4989
4990
sub literal_like {
4991
my ( $self, $like ) = @_;
4992
return unless $like;
4993
$like =~ s/([%_])/\\$1/g;
4994
return "'$like'";
4995
}
4996
4997
sub join_quote {
4998
my ( $self, $default_db, $db_tbl ) = @_;
4999
return unless $db_tbl;
5000
my ($db, $tbl) = split(/[.]/, $db_tbl);
5001
if ( !$tbl ) {
5002
$tbl = $db;
5003
$db = $default_db;
5004
}
5005
$db = "`$db`" if $db && $db !~ m/^`/;
5006
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
5007
return $db ? "$db.$tbl" : $tbl;
5008
}
5009
5010
1;
5011
5012
# ###########################################################################
5013
# End Quoter package
5014
# ###########################################################################
5015
5016
# ###########################################################################
5017
# TableParser package 7156
5018
# This package is a copy without comments from the original. The original
5019
# with comments and its test file can be found in the SVN repository at,
5020
# trunk/common/TableParser.pm
5021
# trunk/common/t/TableParser.t
5022
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
5023
# ###########################################################################
5024
5025
package TableParser;
5026
5027
use strict;
5028
use warnings FATAL => 'all';
5029
use English qw(-no_match_vars);
5030
use Data::Dumper;
5031
$Data::Dumper::Indent = 1;
5032
$Data::Dumper::Sortkeys = 1;
5033
$Data::Dumper::Quotekeys = 0;
5034
5035
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
5036
5037
sub new {
5038
my ( $class, %args ) = @_;
5039
my @required_args = qw(Quoter);
5040
foreach my $arg ( @required_args ) {
5041
die "I need a $arg argument" unless $args{$arg};
5042
}
5043
my $self = { %args };
5044
return bless $self, $class;
5045
}
5046
5047
sub parse {
5048
my ( $self, $ddl, $opts ) = @_;
5049
return unless $ddl;
5050
if ( ref $ddl eq 'ARRAY' ) {
5051
if ( lc $ddl->[0] eq 'table' ) {
5052
$ddl = $ddl->[1];
5053
}
5054
else {
5055
return {
5056
engine => 'VIEW',
5057
};
5058
}
5059
}
5060
5061
if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
5062
die "Cannot parse table definition; is ANSI quoting "
5063
. "enabled or SQL_QUOTE_SHOW_CREATE disabled?";
5064
}
5065
5066
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
5067
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
5068
5069
$ddl =~ s/(`[^`]+`)/\L$1/g;
5070
5071
my $engine = $self->get_engine($ddl);
5072
5073
my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
5074
my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
5075
MKDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
5076
5077
my %def_for;
5078
@def_for{@cols} = @defs;
5079
5080
my (@nums, @null);
5081
my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
5082
foreach my $col ( @cols ) {
5083
my $def = $def_for{$col};
5084
my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
5085
die "Can't determine column type for $def" unless $type;
5086
$type_for{$col} = $type;
5087
if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
5088
push @nums, $col;
5089
$is_numeric{$col} = 1;
5090
}
5091
if ( $def !~ m/NOT NULL/ ) {
5092
push @null, $col;
5093
$is_nullable{$col} = 1;
5094
}
5095
$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
5096
}
5097
5098
my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
5099
5100
my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
5101
5102
return {
5103
name => $name,
5104
cols => \@cols,
5105
col_posn => { map { $cols[$_] => $_ } 0..$#cols },
5106
is_col => { map { $_ => 1 } @cols },
5107
null_cols => \@null,
5108
is_nullable => \%is_nullable,
5109
is_autoinc => \%is_autoinc,
5110
clustered_key => $clustered_key,
5111
keys => $keys,
5112
defs => \%def_for,
5113
numeric_cols => \@nums,
5114
is_numeric => \%is_numeric,
5115
engine => $engine,
5116
type_for => \%type_for,
5117
charset => $charset,
5118
};
5119
}
5120
5121
sub sort_indexes {
5122
my ( $self, $tbl ) = @_;
5123
5124
my @indexes
5125
= sort {
5126
(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
5127
|| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
5128
|| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
5129
|| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
5130
}
5131
grep {
5132
$tbl->{keys}->{$_}->{type} eq 'BTREE'
5133
}
5134
sort keys %{$tbl->{keys}};
5135
5136
MKDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
5137
return @indexes;
5138
}
5139
5140
sub find_best_index {
5141
my ( $self, $tbl, $index ) = @_;
5142
my $best;
5143
if ( $index ) {
5144
($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
5145
}
5146
if ( !$best ) {
5147
if ( $index ) {
5148
die "Index '$index' does not exist in table";
5149
}
5150
else {
5151
($best) = $self->sort_indexes($tbl);
5152
}
5153
}
5154
MKDEBUG && _d('Best index found is', $best);
5155
return $best;
5156
}
5157
5158
sub find_possible_keys {
5159
my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
5160
return () unless $where;
5161
my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
5162
. ' WHERE ' . $where;
5163
MKDEBUG && _d($sql);
5164
my $expl = $dbh->selectrow_hashref($sql);
5165
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
5166
if ( $expl->{possible_keys} ) {
5167
MKDEBUG && _d('possible_keys =', $expl->{possible_keys});
5168
my @candidates = split(',', $expl->{possible_keys});
5169
my %possible = map { $_ => 1 } @candidates;
5170
if ( $expl->{key} ) {
5171
MKDEBUG && _d('MySQL chose', $expl->{key});
5172
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
5173
MKDEBUG && _d('Before deduping:', join(', ', @candidates));
5174
my %seen;
5175
@candidates = grep { !$seen{$_}++ } @candidates;
5176
}
5177
MKDEBUG && _d('Final list:', join(', ', @candidates));
5178
return @candidates;
5179
}
5180
else {
5181
MKDEBUG && _d('No keys in possible_keys');
5182
return ();
5183
}
5184
}
5185
5186
sub check_table {
5187
my ( $self, %args ) = @_;
5188
my @required_args = qw(dbh db tbl);
5189
foreach my $arg ( @required_args ) {
5190
die "I need a $arg argument" unless $args{$arg};
5191
}
5192
my ($dbh, $db, $tbl) = @args{@required_args};
5193
my $q = $self->{Quoter};
5194
my $db_tbl = $q->quote($db, $tbl);
5195
MKDEBUG && _d('Checking', $db_tbl);
5196
5197
my $sql = "SHOW TABLES FROM " . $q->quote($db)
5198
. ' LIKE ' . $q->literal_like($tbl);
5199
MKDEBUG && _d($sql);
5200
my $row;
5201
eval {
5202
$row = $dbh->selectrow_arrayref($sql);
5203
};
5204
if ( $EVAL_ERROR ) {
5205
MKDEBUG && _d($EVAL_ERROR);
5206
return 0;
5207
}
5208
if ( !$row->[0] || $row->[0] ne $tbl ) {
5209
MKDEBUG && _d('Table does not exist');
5210
return 0;
5211
}
5212
5213
MKDEBUG && _d('Table exists; no privs to check');
5214
return 1 unless $args{all_privs};
5215
5216
$sql = "SHOW FULL COLUMNS FROM $db_tbl";
5217
MKDEBUG && _d($sql);
5218
eval {
5219
$row = $dbh->selectrow_hashref($sql);
5220
};
5221
if ( $EVAL_ERROR ) {
5222
MKDEBUG && _d($EVAL_ERROR);
5223
return 0;
5224
}
5225
if ( !scalar keys %$row ) {
5226
MKDEBUG && _d('Table has no columns:', Dumper($row));
5227
return 0;
5228
}
5229
my $privs = $row->{privileges} || $row->{Privileges};
5230
5231
$sql = "DELETE FROM $db_tbl LIMIT 0";
5232
MKDEBUG && _d($sql);
5233
eval {
5234
$dbh->do($sql);
5235
};
5236
my $can_delete = $EVAL_ERROR ? 0 : 1;
5237
5238
MKDEBUG && _d('User privs on', $db_tbl, ':', $privs,
5239
($can_delete ? 'delete' : ''));
5240
5241
if ( !($privs =~ m/select/ && $privs =~ m/insert/ && $privs =~ m/update/
5242
&& $can_delete) ) {
5243
MKDEBUG && _d('User does not have all privs');
5244
return 0;
5245
}
5246
5247
MKDEBUG && _d('User has all privs');
5248
return 1;
5249
}
5250
5251
sub get_engine {
5252
my ( $self, $ddl, $opts ) = @_;
5253
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
5254
MKDEBUG && _d('Storage engine:', $engine);
5255
return $engine || undef;
5256
}
5257
5258
sub get_keys {
5259
my ( $self, $ddl, $opts, $is_nullable ) = @_;
5260
my $engine = $self->get_engine($ddl);
5261
my $keys = {};
5262
my $clustered_key = undef;
5263
5264
KEY:
5265
foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
5266
5267
next KEY if $key =~ m/FOREIGN/;
5268
5269
my $key_ddl = $key;
5270
MKDEBUG && _d('Parsed key:', $key_ddl);
5271
5272
if ( $engine !~ m/MEMORY|HEAP/ ) {
5273
$key =~ s/USING HASH/USING BTREE/;
5274
}
5275
5276
my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
5277
my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
5278
$type = $type || $special || 'BTREE';
5279
if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000'
5280
&& $engine =~ m/HEAP|MEMORY/i )
5281
{
5282
$type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP
5283
}
5284
5285
my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
5286
my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
5287
my @cols;
5288
my @col_prefixes;
5289
foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
5290
my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
5291
push @cols, $name;
5292
push @col_prefixes, $prefix;
5293
}
5294
$name =~ s/`//g;
5295
5296
MKDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
5297
5298
$keys->{$name} = {
5299
name => $name,
5300
type => $type,
5301
colnames => $cols,
5302
cols => \@cols,
5303
col_prefixes => \@col_prefixes,
5304
is_unique => $unique,
5305
is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
5306
is_col => { map { $_ => 1 } @cols },
5307
ddl => $key_ddl,
5308
};
5309
5310
if ( $engine =~ m/InnoDB/i && !$clustered_key ) {
5311
my $this_key = $keys->{$name};
5312
if ( $this_key->{name} eq 'PRIMARY' ) {
5313
$clustered_key = 'PRIMARY';
5314
}
5315
elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
5316
$clustered_key = $this_key->{name};
5317
}
5318
MKDEBUG && $clustered_key && _d('This key is the clustered key');
5319
}
5320
}
5321
5322
return $keys, $clustered_key;
5323
}
5324
5325
sub get_fks {
5326
my ( $self, $ddl, $opts ) = @_;
5327
my $fks = {};
5328
5329
foreach my $fk (
5330
$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
5331
{
5332
my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
5333
my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
5334
my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
5335
5336
if ( $parent !~ m/\./ && $opts->{database} ) {
5337
$parent = "`$opts->{database}`.$parent";
5338
}
5339
5340
$fks->{$name} = {
5341
name => $name,
5342
colnames => $cols,
5343
cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
5344
parent_tbl => $parent,
5345
parent_colnames=> $parent_cols,
5346
parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
5347
ddl => $fk,
5348
};
5349
}
5350
5351
return $fks;
5352
}
5353
5354
sub remove_auto_increment {
5355
my ( $self, $ddl ) = @_;
5356
$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
5357
return $ddl;
5358
}
5359
5360
sub remove_secondary_indexes {
5361
my ( $self, $ddl ) = @_;
5362
my $sec_indexes_ddl;
5363
my $tbl_struct = $self->parse($ddl);
5364
5365
if ( ($tbl_struct->{engine} || '') =~ m/InnoDB/i ) {
5366
my $clustered_key = $tbl_struct->{clustered_key};
5367
$clustered_key ||= '';
5368
5369
my @sec_indexes = map {
5370
my $key_def = $_->{ddl};
5371
$key_def =~ s/([\(\)])/\\$1/g;
5372
$ddl =~ s/\s+$key_def//i;
5373
5374
my $key_ddl = "ADD $_->{ddl}";
5375
$key_ddl .= ',' unless $key_ddl =~ m/,$/;
5376
$key_ddl;
5377
}
5378
grep { $_->{name} ne $clustered_key }
5379
values %{$tbl_struct->{keys}};
5380
MKDEBUG && _d('Secondary indexes:', Dumper(\@sec_indexes));
5381
5382
if ( @sec_indexes ) {
5383
$sec_indexes_ddl = join(' ', @sec_indexes);
5384
$sec_indexes_ddl =~ s/,$//;
5385
}
5386
5387
$ddl =~ s/,(\n\) )/$1/s;
5388
}
5389
else {
5390
MKDEBUG && _d('Not removing secondary indexes from',
5391
$tbl_struct->{engine}, 'table');
5392
}
5393
5394
return $ddl, $sec_indexes_ddl, $tbl_struct;
5395
}
5396
5397
sub _d {
5398
my ($package, undef, $line) = caller 0;
5399
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5400
map { defined $_ ? $_ : 'undef' }
5401
@_;
5402
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5403
}
5404
5405
1;
5406
5407
# ###########################################################################
5408
# End TableParser package
5409
# ###########################################################################
5410
5411
# ###########################################################################
5412
# MysqldumpParser package 7500
5413
# This package is a copy without comments from the original. The original
5414
# with comments and its test file can be found in the SVN repository at,
5415
# trunk/common/MysqldumpParser.pm
5416
# trunk/common/t/MysqldumpParser.t
5417
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
5418
# ###########################################################################
5419
package MysqldumpParser;
5420
5421
{ # package scope
5422
use strict;
5423
use warnings FATAL => 'all';
5424
5425
use English qw(-no_match_vars);
5426
use Data::Dumper;
5427
$Data::Dumper::Indent = 1;
5428
$Data::Dumper::Sortkeys = 1;
5429
$Data::Dumper::Quotekeys = 0;
5430
5431
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
5432
5433
my $open_comment = qr{/\*!\d{5} };
5434
5435
sub new {
5436
my ( $class, %args ) = @_;
5437
my @required_args = qw();
5438
foreach my $arg ( @required_args ) {
5439
die "I need a $arg argument" unless $args{$arg};
5440
}
5441
my $self = {
5442
%args,
5443
};
5444
return bless $self, $class;
5445
}
5446
5447
sub parse_create_tables {
5448
my ( $self, %args ) = @_;
5449
my @required_args = qw(file);
5450
foreach my $arg ( @required_args ) {
5451
die "I need a $arg argument" unless $args{$arg};
5452
}
5453
my ($file) = @args{@required_args};
5454
5455
MKDEBUG && _d('Parsing CREATE TABLE from', $file);
5456
open my $fh, '<', $file
5457
or die "Cannot open $file: $OS_ERROR";
5458
5459
local $INPUT_RECORD_SEPARATOR = '';
5460
5461
my %schema;
5462
my $db = '';
5463
CHUNK:
5464
while (defined(my $chunk = <$fh>)) {
5465
MKDEBUG && _d('db:', $db, 'chunk:', $chunk);
5466
if ($chunk =~ m/Database: (\S+)/) {
5467
$db = $1; # XXX
5468
$db =~ s/^`//; # strip leading `
5469
$db =~ s/`$//; # and trailing `
5470
MKDEBUG && _d('New db:', $db);
5471
}
5472
elsif ($chunk =~ m/CREATE TABLE/) {
5473
MKDEBUG && _d('Chunk has CREATE TABLE');
5474
5475
if ($chunk =~ m/DROP VIEW IF EXISTS/) {
5476
MKDEBUG && _d('Table is a VIEW, skipping');
5477
next CHUNK;
5478
}
5479
5480
my ($create_table)
5481
= $chunk =~ m/^(?:$open_comment)?(CREATE TABLE.+?;)$/ms;
5482
if ( !$create_table ) {
5483
warn "Failed to parse CREATE TABLE from\n" . $chunk;
5484
next CHUNK;
5485
}
5486
$create_table =~ s/ \*\/;\Z/;/; # remove end of version comment
5487
5488
push @{$schema{$db}}, $create_table;
5489
}
5490
else {
5491
MKDEBUG && _d('Chunk has other data, ignoring');
5492
}
5493
}
5494
5495
close $fh;
5496
5497
return \%schema;
5498
}
5499
5500
sub _d {
5501
my ($package, undef, $line) = caller 0;
5502
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5503
map { defined $_ ? $_ : 'undef' }
5504
@_;
5505
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5506
}
5507
5508
} # package scope
5509
1;
5510
5511
# ###########################################################################
5512
# End MysqldumpParser package
5513
# ###########################################################################
5514
5515
# ###########################################################################
5516
# SchemaQualifier package 7499
5517
# This package is a copy without comments from the original. The original
5518
# with comments and its test file can be found in the SVN repository at,
5519
# trunk/common/SchemaQualifier.pm
5520
# trunk/common/t/SchemaQualifier.t
5521
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
5522
# ###########################################################################
5523
package SchemaQualifier;
5524
5525
{ # package scope
5526
use strict;
5527
use warnings FATAL => 'all';
5528
5529
use English qw(-no_match_vars);
5530
use Data::Dumper;
5531
$Data::Dumper::Indent = 1;
5532
$Data::Dumper::Sortkeys = 1;
5533
$Data::Dumper::Quotekeys = 0;
5534
5535
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
5536
5537
sub new {
5538
my ( $class, %args ) = @_;
5539
my @required_args = qw(TableParser Quoter);
5540
foreach my $arg ( @required_args ) {
5541
die "I need a $arg argument" unless $args{$arg};
5542
}
5543
my $self = {
5544
%args,
5545
schema => {}, # db > tbl > col
5546
duplicate_column_name => {},
5547
duplicate_table_name => {},
5548
};
5549
return bless $self, $class;
5550
}
5551
5552
sub schema {
5553
my ( $self ) = @_;
5554
return $self->{schema};
5555
}
5556
5557
sub get_duplicate_column_names {
5558
my ( $self ) = @_;
5559
return keys %{$self->{duplicate_column_name}};
5560
}
5561
5562
sub get_duplicate_table_names {
5563
my ( $self ) = @_;
5564
return keys %{$self->{duplicate_table_name}};
5565
}
5566
5567
sub set_schema_from_mysqldump {
5568
my ( $self, %args ) = @_;
5569
my @required_args = qw(dump);
5570
foreach my $arg ( @required_args ) {
5571
die "I need a $arg argument" unless $args{$arg};
5572
}
5573
my ($dump) = @args{@required_args};
5574
5575
my $schema = $self->{schema};
5576
my $tp = $self->{TableParser};
5577
my %column_name;
5578
my %table_name;
5579
5580
DATABASE:
5581
foreach my $db (keys %$dump) {
5582
if ( !$db ) {
5583
warn "Empty database from parsed mysqldump output";
5584
next DATABASE;
5585
}
5586
5587
TABLE:
5588
foreach my $table_def ( @{$dump->{$db}} ) {
5589
if ( !$table_def ) {
5590
warn "Empty CREATE TABLE for database $db parsed from mysqldump output";
5591
next TABLE;
5592
}
5593
my $tbl_struct = $tp->parse($table_def);
5594
$schema->{$db}->{$tbl_struct->{name}} = $tbl_struct->{is_col};
5595
5596
map { $column_name{$_}++ } @{$tbl_struct->{cols}};
5597
$table_name{$tbl_struct->{name}}++;
5598
}
5599
}
5600
5601
map { $self->{duplicate_column_name}->{$_} = 1 }
5602
grep { $column_name{$_} > 1 }
5603
keys %column_name;
5604
5605
map { $self->{duplicate_table_name}->{$_} = 1 }
5606
grep { $table_name{$_} > 1 }
5607
keys %table_name;
5608
5609
MKDEBUG && _d('Schema:', Dumper($schema));
5610
return;
5611
}
5612
5613
sub qualify_column {
5614
my ( $self, %args ) = @_;
5615
my @required_args = qw(column);
5616
foreach my $arg ( @required_args ) {
5617
die "I need a $arg argument" unless $args{$arg};
5618
}
5619
my ($column) = @args{@required_args};
5620
5621
MKDEBUG && _d('Qualifying', $column);
5622
my ($col, $tbl, $db) = reverse map { s/`//g; $_ } split /[.]/, $column;
5623
MKDEBUG && _d('Column', $column, 'has db', $db, 'tbl', $tbl, 'col', $col);
5624
5625
my %qcol = (
5626
db => $db,
5627
tbl => $tbl,
5628
col => $col,
5629
);
5630
if ( !$qcol{tbl} ) {
5631
@qcol{qw(db tbl)} = $self->get_table_for_column(column => $qcol{col});
5632
}
5633
elsif ( !$qcol{db} ) {
5634
$qcol{db} = $self->get_database_for_table(table => $qcol{tbl});
5635
}
5636
else {
5637
MKDEBUG && _d('Column is already database-table qualified');
5638
}
5639
5640
return \%qcol;
5641
}
5642
5643
sub get_table_for_column {
5644
my ( $self, %args ) = @_;
5645
my @required_args = qw(column);
5646
foreach my $arg ( @required_args ) {
5647
die "I need a $arg argument" unless $args{$arg};
5648
}
5649
my ($col) = @args{@required_args};
5650
MKDEBUG && _d('Getting table for column', $col);
5651
5652
if ( $self->{duplicate_column_name}->{$col} ) {
5653
MKDEBUG && _d('Column name is duplicate, cannot qualify it');
5654
return;
5655
}
5656
5657
my $schema = $self->{schema};
5658
foreach my $db ( keys %{$schema} ) {
5659
foreach my $tbl ( keys %{$schema->{$db}} ) {
5660
if ( $schema->{$db}->{$tbl}->{$col} ) {
5661
MKDEBUG && _d('Column is in database', $db, 'table', $tbl);
5662
return $db, $tbl;
5663
}
5664
}
5665
}
5666
5667
MKDEBUG && _d('Failed to find column in any table');
5668
return;
5669
}
5670
5671
sub get_database_for_table {
5672
my ( $self, %args ) = @_;
5673
my @required_args = qw(table);
5674
foreach my $arg ( @required_args ) {
5675
die "I need a $arg argument" unless $args{$arg};
5676
}
5677
my ($tbl) = @args{@required_args};
5678
MKDEBUG && _d('Getting database for table', $tbl);
5679
5680
if ( $self->{duplicate_table_name}->{$tbl} ) {
5681
MKDEBUG && _d('Table name is duplicate, cannot qualify it');
5682
return;
5683
}
5684
5685
my $schema = $self->{schema};
5686
foreach my $db ( keys %{$schema} ) {
5687
if ( $schema->{$db}->{$tbl} ) {
5688
MKDEBUG && _d('Table is in database', $db);
5689
return $db;
5690
}
5691
}
5692
5693
MKDEBUG && _d('Failed to find table in any database');
5694
return;
5695
}
5696
5697
sub _d {
5698
my ($package, undef, $line) = caller 0;
5699
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
5700
map { defined $_ ? $_ : 'undef' }
5701
@_;
5702
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
5703
}
5704
5705
} # package scope
5706
1;
5707
5708
# ###########################################################################
5709
# End SchemaQualifier package
5710
# ###########################################################################
5711
5712
# ###########################################################################
5713
# This is a combination of modules and programs in one -- a runnable module.
5714
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
5715
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
5716
#
5717
# Check at the end of this package for the call to main() which actually runs
5718
# the program.
5719
# ###########################################################################
5720
package mk_table_usage;
5721
5722
use English qw(-no_match_vars);
5723
use Data::Dumper;
5724
5725
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
5726
5727
use sigtrap 'handler', \&sig_int, 'normal-signals';
5728
5729
Transformers->import(qw(make_checksum));
5730
5731
# Global variables. Only really essential variables should be here.
5732
my $oktorun = 1;
5733
5734
sub main {
5735
@ARGV = @_; # set global ARGV for this package
5736
$oktorun = 1; # reset between tests else pipeline won't run
5737
5738
# ########################################################################
5739
# Get configuration information.
5740
# ########################################################################
5741
my $o = new OptionParser();
5742
$o->get_specs();
5743
$o->get_opts();
5744
5745
my $dp = $o->DSNParser();
5746
$dp->prop('set-vars', $o->get('set-vars'));
5747
5748
$o->usage_or_errors();
5749
5750
# ########################################################################
5751
# Connect to MySQl for --explain-extended.
5752
# ########################################################################
5753
my $explain_ext_dbh;
5754
if ( my $dsn = $o->get('explain-extended') ) {
5755
$explain_ext_dbh = get_cxn(
5756
dsn => $dsn,
5757
OptionParser => $o,
5758
DSNParser => $dp,
5759
);
5760
}
5761
5762
# ########################################################################
5763
# Make common modules.
5764
# ########################################################################
5765
my $qp = new QueryParser();
5766
my $qr = new QueryRewriter(QueryParser => $qp);
5767
my $sp = new SQLParser();
5768
my $tu = new TableUsage(
5769
constant_data_value => $o->get('constant-data-value'),
5770
QueryParser => $qp,
5771
SQLParser => $sp,
5772
);
5773
my %common_modules = (
5774
OptionParser => $o,
5775
DSNParser => $dp,
5776
QueryParser => $qp,
5777
QueryRewriter => $qr,
5778
);
5779
5780
# ########################################################################
5781
# Parse the --create-table-definitions files.
5782
# ########################################################################
5783
if ( my $files = $o->get('create-table-definitions') ) {
5784
my $q = new Quoter();
5785
my $tp = new TableParser(Quoter => $q);
5786
my $sq = new SchemaQualifier(TableParser => $tp, Quoter => $q);
5787
5788
my $dump_parser = new MysqldumpParser();
5789
FILE:
5790
foreach my $file ( @$files ) {
5791
my $dump = $dump_parser->parse_create_tables(file => $file);
5792
if ( !$dump || !keys %$dump ) {
5793
warn "No CREATE TABLE statements were found in $file";
5794
next FILE;
5795
}
5796
$sq->set_schema_from_mysqldump(dump => $dump);
5797
}
5798
$sp->set_SchemaQualifier($sq);
5799
}
5800
5801
# ########################################################################
5802
# Set up an array of callbacks.
5803
# ########################################################################
5804
my $pipeline_data = {
5805
# Add here any data to inject into the pipeline.
5806
# This hashref is $args in each pipeline process.
5807
};
5808
my $pipeline = new Pipeline(
5809
instrument => 0,
5810
continue_on_error => $o->get('continue-on-error'),
5811
);
5812
5813
{ # prep
5814
$pipeline->add(
5815
name => 'prep',
5816
process => sub {
5817
my ( $args ) = @_;
5818
# Stuff you'd like to do to make sure pipeline data is prepped
5819
# and ready to go...
5820
5821
$args->{event} = undef; # remove event from previous pass
5822
5823
if ( $o->got('query') ) {
5824
if ( $args->{query} ) {
5825
delete $args->{query}; # terminate
5826
}
5827
else {
5828
$args->{query} = $o->get('query'); # analyze query once
5829
}
5830
}
5831
5832
return $args;
5833
},
5834
);
5835
} # prep
5836
5837
{ # input
5838
my $fi = new FileIterator();
5839
my $next_file = $fi->get_file_itr(@ARGV);
5840
my $input_fh; # the current input fh
5841
my $pr; # Progress obj for ^
5842
5843
$pipeline->add(
5844
name => 'input',
5845
process => sub {
5846
my ( $args ) = @_;
5847
5848
if ( $o->got('query') ) {
5849
MKDEBUG && _d("No input; using --query");
5850
return $args;
5851
}
5852
5853
# Only get the next file when there's no fh or no more events in
5854
# the current fh. This allows us to do collect-and-report cycles
5855
# (i.e. iterations) on huge files. This doesn't apply to infinite
5856
# inputs because they don't set more_events false.
5857
if ( !$args->{input_fh} || !$args->{more_events} ) {
5858
if ( $args->{input_fh} ) {
5859
close $args->{input_fh}
5860
or die "Cannot close input fh: $OS_ERROR";
5861
}
5862
my ($fh, $filename, $filesize) = $next_file->();
5863
if ( $fh ) {
5864
MKDEBUG && _d('Reading', $filename);
5865
5866
# Create callback to read next event. Some inputs, like
5867
# Processlist, may use something else but most next_event.
5868
if ( my $read_time = $o->get('read-timeout') ) {
5869
$args->{next_event}
5870
= sub { return read_timeout($fh, $read_time); };
5871
}
5872
else {
5873
$args->{next_event} = sub { return <$fh>; };
5874
}
5875
$args->{input_fh} = $fh;
5876
$args->{tell} = sub { return tell $fh; };
5877
$args->{more_events} = 1;
5878
5879
# Make a progress reporter, one per file.
5880
if ( $o->get('progress') && $filename && -e $filename ) {
5881
$pr = new Progress(
5882
jobsize => $filesize,
5883
spec => $o->get('progress'),
5884
name => $filename,
5885
);
5886
}
5887
}
5888
else {
5889
MKDEBUG && _d("No more input");
5890
# This will cause terminator proc to terminate the pipeline.
5891
$args->{input_fh} = undef;
5892
$args->{more_events} = 0;
5893
}
5894
}
5895
$pr->update($args->{tell}) if $pr;
5896
return $args;
5897
},
5898
);
5899
} # input
5900
5901
{ # event
5902
if ( $o->got('query') ) {
5903
$pipeline->add(
5904
name => '--query',
5905
process => sub {
5906
my ( $args ) = @_;
5907
if ( $args->{query} ) {
5908
$args->{event}->{arg} = $args->{query};
5909
}
5910
return $args;
5911
},
5912
);
5913
}
5914
else {
5915
# Only slowlogs are supported, but if we want parse other formats,
5916
# just tweak the code below to be like mk-query-digest.
5917
my %alias_for = (
5918
slowlog => ['SlowLogParser'],
5919
# binlog => ['BinaryLogParser'],
5920
# genlog => ['GeneralLogParser'],
5921
# tcpdump => ['TcpdumpParser','MySQLProtocolParser'],
5922
);
5923
my $type = ['slowlog'];
5924
$type = $alias_for{$type->[0]} if $alias_for{$type->[0]};
5925
5926
foreach my $module ( @$type ) {
5927
my $parser;
5928
eval {
5929
$parser = $module->new(
5930
o => $o,
5931
);
5932
};
5933
if ( $EVAL_ERROR ) {
5934
die "Failed to load $module module: $EVAL_ERROR";
5935
}
5936
5937
$pipeline->add(
5938
name => ref $parser,
5939
process => sub {
5940
my ( $args ) = @_;
5941
if ( $args->{input_fh} ) {
5942
my $event = $parser->parse_event(
5943
event => $args->{event},
5944
next_event => $args->{next_event},
5945
tell => $args->{tell},
5946
oktorun => sub { $args->{more_events} = $_[0]; },
5947
);
5948
if ( $event ) {
5949
$args->{event} = $event;
5950
return $args;
5951
}
5952
MKDEBUG && _d("No more events, input EOF");
5953
return; # next input
5954
}
5955
# No input, let pipeline run so the last report is printed.
5956
return $args;
5957
},
5958
);
5959
}
5960
}
5961
} # event
5962
5963
{ # terminator
5964
my $runtime = new Runtime(
5965
now => sub { return time },
5966
runtime => $o->get('run-time'),
5967
);
5968
5969
$pipeline->add(
5970
name => 'terminator',
5971
process => sub {
5972
my ( $args ) = @_;
5973
5974
# Stop running if there's no more input.
5975
if ( !$args->{input_fh} && !$args->{query} ) {
5976
MKDEBUG && _d("No more input, terminating pipeline");
5977
5978
# This shouldn't happen, but I want to know if it does.
5979
warn "Event in the pipeline but no current input: "
5980
. Dumper($args)
5981
if $args->{event};
5982
5983
$oktorun = 0; # 2. terminate pipeline
5984
return; # 1. exit pipeline early
5985
}
5986
5987
# Stop running if --run-time has elapsed.
5988
if ( !$runtime->have_time() ) {
5989
MKDEBUG && _d("No more time, terminating pipeline");
5990
$oktorun = 0; # 2. terminate pipeline
5991
return; # 1. exit pipeline early
5992
}
5993
5994
# There's input and time left so keep runnning...
5995
if ( $args->{event} ) {
5996
MKDEBUG && _d("Event in pipeline, continuing");
5997
return $args;
5998
}
5999
else {
6000
MKDEBUG && _d("No event in pipeline, get next event");
6001
return;
6002
}
6003
},
6004
);
6005
} # terminator
6006
6007
# ########################################################################
6008
# All pipeline processes after the terminator expect an event
6009
# (i.e. that $args->{event} exists and is a valid event).
6010
# ########################################################################
6011
6012
if ( $o->get('filter') ) { # filter
6013
my $filter = $o->get('filter');
6014
if ( -f $filter && -r $filter ) {
6015
MKDEBUG && _d('Reading file', $filter, 'for --filter code');
6016
open my $fh, "<", $filter or die "Cannot open $filter: $OS_ERROR";
6017
$filter = do { local $/ = undef; <$fh> };
6018
close $fh;
6019
}
6020
else {
6021
$filter = "( $filter )"; # issue 565
6022
}
6023
my $code = 'sub { my ( $args ) = @_; my $event = $args->{event}; '
6024
. "$filter && return \$args; };";
6025
MKDEBUG && _d('--filter code:', $code);
6026
my $sub = eval $code
6027
or die "Error compiling --filter code: $code\n$EVAL_ERROR";
6028
6029
$pipeline->add(
6030
name => 'filter',
6031
process => $sub,
6032
);
6033
} # filter
6034
6035
if ( $explain_ext_dbh ) { # explain extended
6036
my $default_db = $o->get('database');
6037
6038
$pipeline->add(
6039
name => 'explain extended',
6040
process => sub {
6041
my ( $args ) = @_;
6042
my $query = $args->{event}->{arg};
6043
return unless $query;
6044
my $qualified_query;
6045
eval {
6046
$qualified_query = qualify_query(
6047
query => $query,
6048
dbh => $explain_ext_dbh,
6049
db => $args->{event}->{db} || $default_db,
6050
);
6051
};
6052
if ( $EVAL_ERROR ) {
6053
warn $EVAL_ERROR;
6054
return;
6055
}
6056
$args->{event}->{original_arg} = $query;
6057
$args->{event}->{arg} = $qualified_query;
6058
return $args;
6059
},
6060
);
6061
} # explain extended
6062
6063
{ # table usage
6064
my $default_db = $o->get('database');
6065
my $id_attrib = $o->get('id-attribute');
6066
my $queryno = 1;
6067
6068
$pipeline->add(
6069
name => 'table usage',
6070
process => sub {
6071
my ( $args ) = @_;
6072
my $event = $args->{event};
6073
my $query = $event->{arg};
6074
return unless $query;
6075
6076
my $query_id;
6077
if ( $id_attrib ) {
6078
if ( !exists $event->{$id_attrib}
6079
|| !defined $event->{$id_attrib}) {
6080
MKDEBUG && _d("Event", $id_attrib, "attrib doesn't exist",
6081
"or isn't defined, skipping");
6082
return;
6083
}
6084
$query_id = $event->{$id_attrib};
6085
}
6086
else {
6087
$query_id = "0x" . make_checksum(
6088
$qr->fingerprint($event->{original_arg} || $event->{arg}));
6089
}
6090
6091
my $table_usage = $tu->get_table_usage(
6092
query => $query,
6093
default_db => $event->{db} || $default_db,
6094
);
6095
6096
# TODO: I think this will happen for SELECT NOW(); i.e. not
6097
# sure what TableUsage returns for such queries.
6098
if ( !$table_usage || @$table_usage == 0 ) {
6099
MKDEBUG && _d("Query does not use any tables");
6100
return;
6101
}
6102
6103
report_table_usage(
6104
table_usage => $table_usage,
6105
query_id => $query_id,
6106
%common_modules,
6107
);
6108
6109
return $args;
6110
},
6111
);
6112
} # table usage
6113
6114
# ########################################################################
6115
# Daemonize now that everything is setup and ready to work.
6116
# ########################################################################
6117
my $daemon;
6118
if ( $o->get('daemonize') ) {
6119
$daemon = new Daemon(o=>$o);
6120
$daemon->daemonize();
6121
MKDEBUG && _d('I am a daemon now');
6122
}
6123
elsif ( $o->get('pid') ) {
6124
# We're not daemoninzing, it just handles PID stuff.
6125
$daemon = new Daemon(o=>$o);
6126
$daemon->make_PID_file();
6127
}
6128
6129
# ########################################################################
6130
# Parse the input.
6131
# ########################################################################
6132
6133
# Pump the pipeline until either no more input, or we're interrupted by
6134
# CTRL-C, or--this shouldn't happen--the pipeline causes an error. All
6135
# work happens inside the pipeline via the procs we created above.
6136
my $exit_status = 0;
6137
eval {
6138
$pipeline->execute(
6139
oktorun => \$oktorun,
6140
pipeline_data => $pipeline_data,
6141
);
6142
};
6143
if ( $EVAL_ERROR ) {
6144
warn "The pipeline caused an error: $EVAL_ERROR";
6145
$exit_status = 1;
6146
}
6147
MKDEBUG && _d("Pipeline data:", Dumper($pipeline_data));
6148
6149
$explain_ext_dbh->disconnect() if $explain_ext_dbh;
6150
6151
return $exit_status;
6152
} # End main().
6153
6154
# ###########################################################################
6155
# Subroutines.
6156
# ###########################################################################
6157
sub report_table_usage {
6158
my ( %args ) = @_;
6159
my @required_args = qw(table_usage query_id);
6160
foreach my $arg ( @required_args ) {
6161
die "I need a $arg argument" unless $args{$arg};
6162
}
6163
my ($table_usage, $query_id) = @args{@required_args};
6164
MKDEBUG && _d("Reporting table usage");
6165
6166
my $target_tbl_num = 1;
6167
TABLE:
6168
foreach my $table ( @$table_usage ) {
6169
print "Query_id: $query_id." . ($target_tbl_num++) . "\n";
6170
6171
USAGE:
6172
foreach my $usage ( @$table ) {
6173
die "Invalid table usage: " . Dumper($usage)
6174
unless $usage->{context} && $usage->{table};
6175
6176
print "$usage->{context} $usage->{table}\n";
6177
}
6178
print "\n";
6179
}
6180
6181
return;
6182
}
6183
6184
sub qualify_query {
6185
my ( %args ) = @_;
6186
my @required_args = qw(query dbh);
6187
foreach my $arg ( @required_args ) {
6188
die "I need a $arg argument" unless $args{$arg};
6189
}
6190
my ($query, $dbh) = @args{@required_args};
6191
my $sql;
6192
6193
if ( my $db = $args{db} ) {
6194
$sql = "USE $db";
6195
MKDEBUG && _d($dbh, $sql);
6196
$dbh->do($sql);
6197
}
6198
6199
$sql = "EXPLAIN EXTENDED $query";
6200
MKDEBUG && _d($dbh, $sql);
6201
$dbh->do($sql); # don't need the result
6202
6203
$sql = "SHOW WARNINGS";
6204
MKDEBUG && _d($dbh, $sql);
6205
my $warning = $dbh->selectrow_hashref($sql);
6206
if ( ($warning->{level} || "") !~ m/Note/i
6207
|| ($warning->{code} || 0) != 1003 ) {
6208
die "EXPLAIN EXTENDED failed:\n"
6209
. " Level: " . ($warning->{level} || "") . "\n"
6210
. " Code: " . ($warning->{code} || "") . "\n"
6211
. "Message: " . ($warning->{message} || "") . "\n";
6212
}
6213
6214
return $warning->{message};
6215
}
6216
6217
sub get_cxn {
6218
my ( %args ) = @_;
6219
my @required_args = qw(dsn OptionParser DSNParser);
6220
foreach my $arg ( @required_args ) {
6221
die "I need a $arg argument" unless $args{$arg};
6222
}
6223
my ($dsn, $o, $dp) = @args{@required_args};
6224
6225
if ( $o->get('ask-pass') ) {
6226
$dsn->{p} = OptionParser::prompt_noecho("Enter password "
6227
. ($args{for} ? "for $args{for}: " : ": "));
6228
}
6229
6230
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), $args{opts});
6231
$dbh->{FetchHashKeyName} = 'NAME_lc';
6232
return $dbh;
6233
}
6234
6235
sub sig_int {
6236
my ( $signal ) = @_;
6237
if ( $oktorun ) {
6238
print STDERR "# Caught SIG$signal.\n";
6239
$oktorun = 0;
6240
}
6241
else {
6242
print STDERR "# Exiting on SIG$signal.\n";
6243
exit(1);
6244
}
6245
}
6246
6247
sub _d {
6248
my ($package, undef, $line) = caller 0;
6249
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
6250
map { defined $_ ? $_ : 'undef' }
6251
@_;
6252
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
6253
}
6254
6255
# ############################################################################
6256
# Run the program.
6257
# ############################################################################
6258
if ( !caller ) { exit main(@ARGV); }
6259
6260
1; # Because this is a module as well as a script.
6261
6262
# #############################################################################
6263
# Documentation.
6264
# #############################################################################
6265
6266
=pod
6267
6268
=head1 NAME
6269
6270
mk-table-usage - Read queries from a log and analyze how they use tables.
6271
6272
=head1 SYNOPSIS
6273
6274
Usage: mk-table-usage [OPTION...] [FILE...]
6275
6276
mk-table-usage reads queries from slow query logs and analyzes how they use
6277
tables. If no FILE is specified, STDIN is read. Table usage for every query
6278
is printed to STDOUT.
6279
6280
=head1 RISKS
6281
6282
mk-table-use is very low risk because it only reads and examines queries from
6283
a log and executes C<EXPLAIN EXTENDED> if the L<"--explain-extended"> option
6284
is specified.
6285
6286
At the time of this release, there are no known bugs that could cause serious
6287
harm to users.
6288
6289
The authoritative source for updated information is always the online issue
6290
tracking system. Issues that affect this tool will be marked as such. You can
6291
see a list of such issues at the following URL:
6292
L<http://www.maatkit.org/bugs/mk-table-usage>.
6293
6294
See also L<"BUGS"> for more information on filing bugs and getting help.
6295
6296
=head1 DESCRIPTION
6297
6298
mk-table-usage reads queries from slow query logs and analyzes how they use
6299
tables. Table usage indicates more than just which tables are read from or
6300
written to by the query, it also indicates data flow: data in and data out.
6301
Data flow is determined by the contexts in which tables are used by the query.
6302
A single table can be used in several different contexts in the same query.
6303
The reported table usage for each query lists every context for every table.
6304
This CONTEXT-TABLE list tells how and where data flows, i.e. the query's table
6305
usage. The L<"OUTPUT"> section lists the possible contexts and describes how
6306
to read a table usage report.
6307
6308
Since this tool analyzes table usage, it's important that queries use
6309
table-qualified columns. If a query uses only one table, then all columns
6310
must be from that table and there's no problem. But if a query uses
6311
multiple tables and the columns are not table-qualified, then that creates a
6312
problem that can only be solved by knowing the query's database and specifying
6313
L<"--explain-extended">. If the slow log does not specify the database
6314
used by the query, then you can specify a default database with L<"--database">.
6315
There is no other way to know or guess the database, so the query will be
6316
skipped. Secondly, if the database is known, then specifying
6317
L<"--explain-extended"> causes mk-table-usage to do C<EXPLAIN EXTENDED ...>
6318
C<SHOW WARNINGS> to get the fully qualified query as reported by MySQL
6319
(i.e. all identifiers are fully database- and/or table-qualified). For
6320
best results, you should specify L<"--explain-extended"> and
6321
L<"--database"> if you know that all queries use the same database.
6322
6323
Each query is identified in the output by either an MD5 hex checksum
6324
of the query's fingerprint or the query's value for the specified
6325
L<"--id-attribute">. The query ID is for parsing and storing the table
6326
usage reports in a table that is keyed on the query ID. See L<"OUTPUT">
6327
for more information.
6328
6329
=head1 OUTPUT
6330
6331
The table usage report that is printed for each query looks similar to the
6332
following:
6333
6334
Query_id: 0x1CD27577D202A339.1
6335
UPDATE t1
6336
SELECT DUAL
6337
JOIN t1
6338
JOIN t2
6339
WHERE t1
6340
6341
Query_id: 0x1CD27577D202A339.2
6342
UPDATE t2
6343
SELECT DUAL
6344
JOIN t1
6345
JOIN t2
6346
WHERE t1
6347
6348
Usage reports are separated by blank lines. The first line is always the
6349
query ID: a unique ID that can be used to parse the output and store the
6350
usage reports in a table keyed on this ID. The query ID has two parts
6351
separated by a period: the query ID and the target table number.
6352
6353
If L<"--id-attribute"> is not specified, then query IDs are automatically
6354
created by making an MD5 hex checksum of the query's fingerprint
6355
(as shown above, e.g. C<0x1CD27577D202A339>); otherwise, the query ID is the
6356
query's value for the given attribute.
6357
6358
The target table number starts at 1 and increments by 1 for each table that
6359
the query affects. Only multi-table UPDATE queries can affect
6360
multiple tables with a single query, so this number is 1 for all other types
6361
of queries. (Multi-table DELETE queries are not supported.)
6362
The example output above is from this query:
6363
6364
UPDATE t1 AS a JOIN t2 AS b USING (id)
6365
SET a.foo="bar", b.foo="bat"
6366
WHERE a.id=1;
6367
6368
The C<SET> clause indicates that two tables are updated: C<a> aliased as C<t1>,
6369
and C<b> aliased as C<t2>. So two usage reports are printed, one for each
6370
table, and this is indicated in the output by their common query ID but
6371
incrementing target table number.
6372
6373
After the first line is a variable number of CONTEXT-TABLE lines. Possible
6374
contexts are:
6375
6376
=over
6377
6378
=item * SELECT
6379
6380
SELECT means that data is taken out of the table for one of two reasons:
6381
to be returned to the user as part of a result set, or to be put into another
6382
table as part of an INSERT or UPDATE. In the first case, since only SELECT
6383
queries return result sets, a SELECT context is always listed for SELECT
6384
queries. In the second case, data from one table is used to insert or
6385
update rows in another table. For example, the UPDATE query in the example
6386
above has the usage:
6387
6388
SELECT DUAL
6389
6390
This refers to:
6391
6392
SET a.foo="bar", b.foo="bat"
6393
6394
DUAL is used for any values that does not originate in a table, in this case the
6395
literal values "bar" and "bat". If that C<SET> clause were C<SET a.foo=b.foo>
6396
instead, then the complete usage would be:
6397
6398
Query_id: 0x1CD27577D202A339.1
6399
UPDATE t1
6400
SELECT t2
6401
JOIN t1
6402
JOIN t2
6403
WHERE t1
6404
6405
The presence of a SELECT context after another context, such as UPDATE or
6406
INSERT, indicates where the UPDATE or INSERT retrieves its data. The example
6407
immediately above reflects an UPDATE query that updates rows in table C<t1>
6408
with data from table C<t2>.
6409
6410
=item * Any other query type
6411
6412
Any other query type, such as INSERT, UPDATE, DELETE, etc. may be a context.
6413
All these types indicate that the table is written or altered in some way.
6414
If a SELECT context follows one of these types, then data is read from the
6415
SELECT table and written to this table. This happens, for example, with
6416
INSERT..SELECT or UPDATE queries that set column values using values from
6417
tables instead of constant values.
6418
6419
These query types are not supported:
6420
6421
SET
6422
LOAD
6423
multi-table DELETE
6424
6425
=item * JOIN
6426
6427
The JOIN context lists tables that are joined, either with an explicit JOIN in
6428
the FROM clause, or implicitly in the WHERE clause, such as C<t1.id = t2.id>.
6429
6430
=item * WHERE
6431
6432
The WHERE context lists tables that are used in the WHERE clause to filter
6433
results. This does not include tables that are implicitly joined in the
6434
WHERE clause; those are listed as JOIN contexts. For example:
6435
6436
WHERE t1.id > 100 AND t1.id < 200 AND t2.foo IS NOT NULL
6437
6438
Results in:
6439
6440
WHERE t1
6441
WHERE t2
6442
6443
Only unique tables are listed; that is why table C<t1> is listed only once.
6444
6445
=item * TLIST
6446
6447
The TLIST context lists tables that are accessed by the query but do not
6448
appear in any other context. These tables are usually an implicit
6449
full cartesian join, so they should be avoided. For example, the query
6450
C<SELECT * FROM t1, t2> results in:
6451
6452
Query_id: 0xBDDEB6EDA41897A8.1
6453
SELECT t1
6454
SELECT t2
6455
TLIST t1
6456
TLIST t2
6457
6458
First of all, there are two SELECT contexts, because C<SELECT *> selects
6459
rows from all tables; C<t1> and C<t2> in this case. Secondly, the tables
6460
are implicitly joined, but without any kind of join condition, which results
6461
in a full cartesian join as indicated by the TLIST context for each.
6462
6463
=back
6464
6465
=head1 EXIT STATUS
6466
6467
mk-table-usage exits 1 on any kind of error, or 0 if no errors.
6468
6469
=head1 OPTIONS
6470
6471
This tool accepts additional command-line arguments. Refer to the
6472
L<"SYNOPSIS"> and usage information for details.
6473
6474
=over
6475
6476
=item --ask-pass
6477
6478
Prompt for a password when connecting to MySQL.
6479
6480
=item --charset
6481
6482
short form: -A; type: string
6483
6484
Default character set. If the value is utf8, sets Perl's binmode on
6485
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and
6486
runs SET NAMES UTF8 after connecting to MySQL. Any other value sets
6487
binmode on STDOUT without the utf8 layer, and runs SET NAMES after
6488
connecting to MySQL.
6489
6490
=item --config
6491
6492
type: Array
6493
6494
Read this comma-separated list of config files; if specified, this must be the
6495
first option on the command line.
6496
6497
=item --constant-data-value
6498
6499
type: string; default: DUAL
6500
6501
Value to print for constant data. Constant data means all data not
6502
from tables (or subqueries since subqueries are not supported). For example,
6503
real constant values like strings ("foo") and numbers (42), and data from
6504
functions like C<NOW()>. For example, in the query
6505
C<INSERT INTO t (c) VALUES ('a')>, the string 'a' is constant data, so the
6506
table usage report is:
6507
6508
INSERT t
6509
SELECT DUAL
6510
6511
The first line indicates that data is inserted into table C<t> and the second
6512
line indicates that that data comes from some constant value.
6513
6514
=item --[no]continue-on-error
6515
6516
default: yes
6517
6518
Continue parsing even if there is an error.
6519
6520
=item --create-table-definitions
6521
6522
type: array
6523
6524
Read C<CREATE TABLE> definitions from this list of comma-separated files.
6525
If you cannot use L<"--explain-extended"> to fully qualify table and column
6526
names, you can save the output of C<mysqldump --no-data> to one or more files
6527
and specify those files with this option. The tool will parse all
6528
C<CREATE TABLE> definitions from the files and use this information to
6529
qualify table and column names. If a column name is used in multiple tables,
6530
or table name is used in multiple databases, these duplicates cannot be
6531
qualified.
6532
6533
=item --daemonize
6534
6535
Fork to the background and detach from the shell. POSIX
6536
operating systems only.
6537
6538
=item --database
6539
6540
short form: -D; type: string
6541
6542
Default database.
6543
6544
=item --defaults-file
6545
6546
short form: -F; type: string
6547
6548
Only read mysql options from the given file. You must give an absolute pathname.
6549
6550
=item --explain-extended
6551
6552
type: DSN
6553
6554
EXPLAIN EXTENDED queries on this host to fully qualify table and column names.
6555
6556
=item --filter
6557
6558
type: string
6559
6560
Discard events for which this Perl code doesn't return true.
6561
6562
This option is a string of Perl code or a file containing Perl code that gets
6563
compiled into a subroutine with one argument: $event. This is a hashref.
6564
If the given value is a readable file, then mk-query-digest reads the entire
6565
file and uses its contents as the code. The file should not contain
6566
a shebang (#!/usr/bin/perl) line.
6567
6568
If the code returns true, the chain of callbacks continues; otherwise it ends.
6569
The code is the last statement in the subroutine other than C<return $event>.
6570
The subroutine template is:
6571
6572
sub { $event = shift; filter && return $event; }
6573
6574
Filters given on the command line are wrapped inside parentheses like like
6575
C<( filter )>. For complex, multi-line filters, you must put the code inside
6576
a file so it will not be wrapped inside parentheses. Either way, the filter
6577
must produce syntactically valid code given the template. For example, an
6578
if-else branch given on the command line would not be valid:
6579
6580
--filter 'if () { } else { }' # WRONG
6581
6582
Since it's given on the command line, the if-else branch would be wrapped inside
6583
parentheses which is not syntactically valid. So to accomplish something more
6584
complex like this would require putting the code in a file, for example
6585
filter.txt:
6586
6587
my $event_ok; if (...) { $event_ok=1; } else { $event_ok=0; } $event_ok
6588
6589
Then specify C<--filter filter.txt> to read the code from filter.txt.
6590
6591
If the filter code won't compile, mk-query-digest will die with an error.
6592
If the filter code does compile, an error may still occur at runtime if the
6593
code tries to do something wrong (like pattern match an undefined value).
6594
mk-query-digest does not provide any safeguards so code carefully!
6595
6596
An example filter that discards everything but SELECT statements:
6597
6598
--filter '$event->{arg} =~ m/^select/i'
6599
6600
This is compiled into a subroutine like the following:
6601
6602
sub { $event = shift; ( $event->{arg} =~ m/^select/i ) && return $event; }
6603
6604
It is permissible for the code to have side effects (to alter C<$event>).
6605
6606
You can find an explanation of the structure of $event at
6607
L<http://code.google.com/p/maatkit/wiki/EventAttributes>.
6608
6609
Here are more examples of filter code:
6610
6611
=over
6612
6613
=item Host/IP matches domain.com
6614
6615
--filter '($event->{host} || $event->{ip} || "") =~ m/domain.com/'
6616
6617
Sometimes MySQL logs the host where the IP is expected. Therefore, we
6618
check both.
6619
6620
=item User matches john
6621
6622
--filter '($event->{user} || "") =~ m/john/'
6623
6624
=item More than 1 warning
6625
6626
--filter '($event->{Warning_count} || 0) > 1'
6627
6628
=item Query does full table scan or full join
6629
6630
--filter '(($event->{Full_scan} || "") eq "Yes") || (($event->{Full_join} || "") eq "Yes")'
6631
6632
=item Query was not served from query cache
6633
6634
--filter '($event->{QC_Hit} || "") eq "No"'
6635
6636
=item Query is 1 MB or larger
6637
6638
--filter '$event->{bytes} >= 1_048_576'
6639
6640
=back
6641
6642
Since L<"--filter"> allows you to alter C<$event>, you can use it to do other
6643
things, like create new attributes.
6644
6645
6646
=item --help
6647
6648
Show help and exit.
6649
6650
=item --host
6651
6652
short form: -h; type: string
6653
6654
Connect to host.
6655
6656
=item --id-attribute
6657
6658
type: string
6659
6660
Identify each event using this attribute. If not ID attribute is given, then
6661
events are identified with the query's checksum: an MD5 hex checksum of the
6662
query's fingerprint.
6663
6664
=item --log
6665
6666
type: string
6667
6668
Print all output to this file when daemonized.
6669
6670
=item --password
6671
6672
short form: -p; type: string
6673
6674
Password to use when connecting.
6675
6676
=item --pid
6677
6678
type: string
6679
6680
Create the given PID file when running. The file contains the process
6681
ID of the daemonized instance. The PID file is removed when the
6682
daemonized instance exits. The program checks for the existence of the
6683
PID file when starting; if it exists and the process with the matching PID
6684
exists, the program exits.
6685
6686
=item --port
6687
6688
short form: -P; type: int
6689
6690
Port number to use for connection.
6691
6692
=item --progress
6693
6694
type: array; default: time,30
6695
6696
Print progress reports to STDERR. The value is a comma-separated list with two
6697
parts. The first part can be percentage, time, or iterations; the second part
6698
specifies how often an update should be printed, in percentage, seconds, or
6699
number of iterations.
6700
6701
=item --query
6702
6703
type: string
6704
6705
Analyze only this given query. If you want to analyze the table usage of
6706
one simple query by providing on the command line instead of reading it
6707
from a slow log file, then specify that query with this option. The default
6708
L<"--id-attribute"> will be used which is the query's checksum.
6709
6710
=item --read-timeout
6711
6712
type: time; default: 0
6713
6714
Wait this long for an event from the input; 0 to wait forever.
6715
6716
This option sets the maximum time to wait for an event from the input. If an
6717
event is not received after the specified time, the script stops reading the
6718
input and prints its reports.
6719
6720
This option requires the Perl POSIX module.
6721
6722
=item --run-time
6723
6724
type: time
6725
6726
How long to run before exiting. The default is to run forever (you can
6727
interrupt with CTRL-C).
6728
6729
=item --set-vars
6730
6731
type: string; default: wait_timeout=10000
6732
6733
Set these MySQL variables. Immediately after connecting to MySQL, this
6734
string will be appended to SET and executed.
6735
6736
=item --socket
6737
6738
short form: -S; type: string
6739
6740
Socket file to use for connection.
6741
6742
=item --user
6743
6744
short form: -u; type: string
6745
6746
User for login if not current user.
6747
6748
=item --version
6749
6750
Show version and exit.
6751
6752
=back
6753
6754
=head1 DSN OPTIONS
6755
6756
These DSN options are used to create a DSN. Each option is given like
6757
C<option=value>. The options are case-sensitive, so P and p are not the
6758
same option. There cannot be whitespace before or after the C<=> and
6759
if the value contains whitespace it must be quoted. DSN options are
6760
comma-separated. See the L<maatkit> manpage for full details.
6761
6762
=over
6763
6764
=item * A
6765
6766
dsn: charset; copy: yes
6767
6768
Default character set.
6769
6770
=item * D
6771
6772
dsn: database; copy: yes
6773
6774
Database that contains the query review table.
6775
6776
=item * F
6777
6778
dsn: mysql_read_default_file; copy: yes
6779
6780
Only read default options from the given file
6781
6782
=item * h
6783
6784
dsn: host; copy: yes
6785
6786
Connect to host.
6787
6788
=item * p
6789
6790
dsn: password; copy: yes
6791
6792
Password to use when connecting.
6793
6794
=item * P
6795
6796
dsn: port; copy: yes
6797
6798
Port number to use for connection.
6799
6800
=item * S
6801
6802
dsn: mysql_socket; copy: yes
6803
6804
Socket file to use for connection.
6805
6806
=item * u
6807
6808
dsn: user; copy: yes
6809
6810
User for login if not current user.
6811
6812
=back
6813
6814
=head1 DOWNLOADING
6815
6816
You can download Maatkit from Google Code at
6817
L<http://code.google.com/p/maatkit/>, or you can get any of the tools
6818
easily with a command like the following:
6819
6820
wget http://www.maatkit.org/get/toolname
6821
or
6822
wget http://www.maatkit.org/trunk/toolname
6823
6824
Where C<toolname> can be replaced with the name (or fragment of a name) of any
6825
of the Maatkit tools. Once downloaded, they're ready to run; no installation is
6826
needed. The first URL gets the latest released version of the tool, and the
6827
second gets the latest trunk code from Subversion.
6828
6829
=head1 ENVIRONMENT
6830
6831
The environment variable C<MKDEBUG> enables verbose debugging output in all of
6832
the Maatkit tools:
6833
6834
MKDEBUG=1 mk-....
6835
6836
=head1 SYSTEM REQUIREMENTS
6837
6838
You need Perl and some core packages that ought to be installed in any
6839
reasonably new version of Perl.
6840
6841
=head1 BUGS
6842
6843
For a list of known bugs see L<http://www.maatkit.org/bugs/mk-table-usage>.
6844
6845
Please use Google Code Issues and Groups to report bugs or request support:
6846
L<http://code.google.com/p/maatkit/>. You can also join #maatkit on Freenode to
6847
discuss Maatkit.
6848
6849
Please include the complete command-line used to reproduce the problem you are
6850
seeing, the version of all MySQL servers involved, the complete output of the
6851
tool when run with L<"--version">, and if possible, debugging output produced by
6852
running with the C<MKDEBUG=1> environment variable.
6853
6854
=head1 COPYRIGHT, LICENSE AND WARRANTY
6855
6856
This program is copyright 2009-@CURRENTYEAR@ Percona Inc.
6857
Feedback and improvements are welcome.
6858
6859
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
6860
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
6861
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
6862
6863
This program is free software; you can redistribute it and/or modify it under
6864
the terms of the GNU General Public License as published by the Free Software
6865
Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
6866
systems, you can issue `man perlgpl' or `man perlartistic' to read these
6867
licenses.
6868
6869
You should have received a copy of the GNU General Public License along with
6870
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
6871
Place, Suite 330, Boston, MA 02111-1307 USA.
6872
6873
=head1 AUTHOR
6874
6875
Daniel Nichter
6876
6877
=head1 VERSION
6878
6879
This manual page documents Ver @VERSION@ Distrib @DISTRIB@ $Revision: 7531 $.
6880
6881
=cut
Loggerhead is a web-based interface for Breezy
Version: 2.0.1