3
# This program is copyright 2011-@CURRENTYEAR@ Percona Inc.
4
# This program is copyright 2007-2011 Baron Schwartz.
5
# Feedback and improvements are welcome.
7
# THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
8
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
9
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
11
# This program is free software; you can redistribute it and/or modify it under
12
# the terms of the GNU General Public License as published by the Free Software
13
# Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
14
# systems, you can issue `man perlgpl' or `man perlartistic' to read these
17
# You should have received a copy of the GNU General Public License along with
18
# this program; if not, write to the Free Software Foundation, Inc., 59 Temple
19
# Place, Suite 330, Boston, MA 02111-1307 USA.
22
use warnings FATAL => 'all';
24
our $VERSION = '@VERSION@';
25
our $DISTRIB = '@DISTRIB@';
26
our $SVN_REV = sprintf("%d", (q$Revision: 7477 $ =~ m/(\d+)/g, 0));
28
# ###########################################################################
29
# VersionParser package 6667
30
# This package is a copy without comments from the original. The original
31
# with comments and its test file can be found in the SVN repository at,
32
# trunk/common/VersionParser.pm
33
# trunk/common/t/VersionParser.t
34
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
35
# ###########################################################################
36
package VersionParser;
39
use warnings FATAL => 'all';
41
use English qw(-no_match_vars);
43
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
51
my ( $self, $str ) = @_;
52
my $result = sprintf('%03d%03d%03d', $str =~ m/(\d+)/g);
53
MKDEBUG && _d($str, 'parses to', $result);
58
my ( $self, $dbh, $target ) = @_;
59
if ( !$self->{$dbh} ) {
60
$self->{$dbh} = $self->parse(
61
$dbh->selectrow_array('SELECT VERSION()'));
63
my $result = $self->{$dbh} ge $self->parse($target) ? 1 : 0;
64
MKDEBUG && _d($self->{$dbh}, 'ge', $target, ':', $result);
69
my ( $self, $dbh ) = @_;
71
my $innodb_version = "NO";
74
grep { $_->{engine} =~ m/InnoDB/i }
77
@hash{ map { lc $_ } keys %$_ } = values %$_;
80
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
82
MKDEBUG && _d("InnoDB support:", $innodb->{support});
83
if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
84
my $vars = $dbh->selectrow_hashref(
85
"SHOW VARIABLES LIKE 'innodb_version'");
86
$innodb_version = !$vars ? "BUILTIN"
87
: ($vars->{Value} || $vars->{value});
90
$innodb_version = $innodb->{support}; # probably DISABLED or NO
94
MKDEBUG && _d("InnoDB version:", $innodb_version);
95
return $innodb_version;
99
my ($package, undef, $line) = caller 0;
100
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
101
map { defined $_ ? $_ : 'undef' }
103
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
108
# ###########################################################################
109
# End VersionParser package
110
# ###########################################################################
112
# ###########################################################################
113
# Quoter package 6850
114
# This package is a copy without comments from the original. The original
115
# with comments and its test file can be found in the SVN repository at,
116
# trunk/common/Quoter.pm
117
# trunk/common/t/Quoter.t
118
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
119
# ###########################################################################
124
use warnings FATAL => 'all';
125
use English qw(-no_match_vars);
127
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
130
my ( $class, %args ) = @_;
131
return bless {}, $class;
135
my ( $self, @vals ) = @_;
136
foreach my $val ( @vals ) {
139
return join('.', map { '`' . $_ . '`' } @vals);
143
my ( $self, $val ) = @_;
145
return 'NULL' unless defined $val; # undef = NULL
146
return "''" if $val eq ''; # blank string = ''
147
return $val if $val =~ m/^0x[0-9a-fA-F]+$/; # hex data
149
$val =~ s/(['\\])/\\$1/g;
154
my ( $self, $db_tbl, $default_db ) = @_;
156
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
165
my ( $self, $like ) = @_;
167
$like =~ s/([%_])/\\$1/g;
172
my ( $self, $default_db, $db_tbl ) = @_;
173
return unless $db_tbl;
174
my ($db, $tbl) = split(/[.]/, $db_tbl);
179
$db = "`$db`" if $db && $db !~ m/^`/;
180
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
181
return $db ? "$db.$tbl" : $tbl;
186
# ###########################################################################
188
# ###########################################################################
190
# ###########################################################################
191
# TableParser package 7156
192
# This package is a copy without comments from the original. The original
193
# with comments and its test file can be found in the SVN repository at,
194
# trunk/common/TableParser.pm
195
# trunk/common/t/TableParser.t
196
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
197
# ###########################################################################
202
use warnings FATAL => 'all';
203
use English qw(-no_match_vars);
205
$Data::Dumper::Indent = 1;
206
$Data::Dumper::Sortkeys = 1;
207
$Data::Dumper::Quotekeys = 0;
209
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
212
my ( $class, %args ) = @_;
213
my @required_args = qw(Quoter);
214
foreach my $arg ( @required_args ) {
215
die "I need a $arg argument" unless $args{$arg};
217
my $self = { %args };
218
return bless $self, $class;
222
my ( $self, $ddl, $opts ) = @_;
224
if ( ref $ddl eq 'ARRAY' ) {
225
if ( lc $ddl->[0] eq 'table' ) {
235
if ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
236
die "Cannot parse table definition; is ANSI quoting "
237
. "enabled or SQL_QUOTE_SHOW_CREATE disabled?";
240
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
241
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
243
$ddl =~ s/(`[^`]+`)/\L$1/g;
245
my $engine = $self->get_engine($ddl);
247
my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
248
my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
249
MKDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
252
@def_for{@cols} = @defs;
255
my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
256
foreach my $col ( @cols ) {
257
my $def = $def_for{$col};
258
my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
259
die "Can't determine column type for $def" unless $type;
260
$type_for{$col} = $type;
261
if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
263
$is_numeric{$col} = 1;
265
if ( $def !~ m/NOT NULL/ ) {
267
$is_nullable{$col} = 1;
269
$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
272
my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
274
my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
279
col_posn => { map { $cols[$_] => $_ } 0..$#cols },
280
is_col => { map { $_ => 1 } @cols },
282
is_nullable => \%is_nullable,
283
is_autoinc => \%is_autoinc,
284
clustered_key => $clustered_key,
287
numeric_cols => \@nums,
288
is_numeric => \%is_numeric,
290
type_for => \%type_for,
296
my ( $self, $tbl ) = @_;
300
(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
301
|| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
302
|| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
303
|| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
306
$tbl->{keys}->{$_}->{type} eq 'BTREE'
308
sort keys %{$tbl->{keys}};
310
MKDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
314
sub find_best_index {
315
my ( $self, $tbl, $index ) = @_;
318
($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
322
die "Index '$index' does not exist in table";
325
($best) = $self->sort_indexes($tbl);
328
MKDEBUG && _d('Best index found is', $best);
332
sub find_possible_keys {
333
my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
334
return () unless $where;
335
my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
336
. ' WHERE ' . $where;
338
my $expl = $dbh->selectrow_hashref($sql);
339
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
340
if ( $expl->{possible_keys} ) {
341
MKDEBUG && _d('possible_keys =', $expl->{possible_keys});
342
my @candidates = split(',', $expl->{possible_keys});
343
my %possible = map { $_ => 1 } @candidates;
344
if ( $expl->{key} ) {
345
MKDEBUG && _d('MySQL chose', $expl->{key});
346
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
347
MKDEBUG && _d('Before deduping:', join(', ', @candidates));
349
@candidates = grep { !$seen{$_}++ } @candidates;
351
MKDEBUG && _d('Final list:', join(', ', @candidates));
355
MKDEBUG && _d('No keys in possible_keys');
361
my ( $self, %args ) = @_;
362
my @required_args = qw(dbh db tbl);
363
foreach my $arg ( @required_args ) {
364
die "I need a $arg argument" unless $args{$arg};
366
my ($dbh, $db, $tbl) = @args{@required_args};
367
my $q = $self->{Quoter};
368
my $db_tbl = $q->quote($db, $tbl);
369
MKDEBUG && _d('Checking', $db_tbl);
371
my $sql = "SHOW TABLES FROM " . $q->quote($db)
372
. ' LIKE ' . $q->literal_like($tbl);
376
$row = $dbh->selectrow_arrayref($sql);
379
MKDEBUG && _d($EVAL_ERROR);
382
if ( !$row->[0] || $row->[0] ne $tbl ) {
383
MKDEBUG && _d('Table does not exist');
387
MKDEBUG && _d('Table exists; no privs to check');
388
return 1 unless $args{all_privs};
390
$sql = "SHOW FULL COLUMNS FROM $db_tbl";
393
$row = $dbh->selectrow_hashref($sql);
396
MKDEBUG && _d($EVAL_ERROR);
399
if ( !scalar keys %$row ) {
400
MKDEBUG && _d('Table has no columns:', Dumper($row));
403
my $privs = $row->{privileges} || $row->{Privileges};
405
$sql = "DELETE FROM $db_tbl LIMIT 0";
410
my $can_delete = $EVAL_ERROR ? 0 : 1;
412
MKDEBUG && _d('User privs on', $db_tbl, ':', $privs,
413
($can_delete ? 'delete' : ''));
415
if ( !($privs =~ m/select/ && $privs =~ m/insert/ && $privs =~ m/update/
417
MKDEBUG && _d('User does not have all privs');
421
MKDEBUG && _d('User has all privs');
426
my ( $self, $ddl, $opts ) = @_;
427
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
428
MKDEBUG && _d('Storage engine:', $engine);
429
return $engine || undef;
433
my ( $self, $ddl, $opts, $is_nullable ) = @_;
434
my $engine = $self->get_engine($ddl);
436
my $clustered_key = undef;
439
foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
441
next KEY if $key =~ m/FOREIGN/;
444
MKDEBUG && _d('Parsed key:', $key_ddl);
446
if ( $engine !~ m/MEMORY|HEAP/ ) {
447
$key =~ s/USING HASH/USING BTREE/;
450
my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
451
my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
452
$type = $type || $special || 'BTREE';
453
if ( $opts->{mysql_version} && $opts->{mysql_version} lt '004001000'
454
&& $engine =~ m/HEAP|MEMORY/i )
456
$type = 'HASH'; # MySQL pre-4.1 supports only HASH indexes on HEAP
459
my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
460
my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
463
foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
464
my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
466
push @col_prefixes, $prefix;
470
MKDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
477
col_prefixes => \@col_prefixes,
478
is_unique => $unique,
479
is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
480
is_col => { map { $_ => 1 } @cols },
484
if ( $engine =~ m/InnoDB/i && !$clustered_key ) {
485
my $this_key = $keys->{$name};
486
if ( $this_key->{name} eq 'PRIMARY' ) {
487
$clustered_key = 'PRIMARY';
489
elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
490
$clustered_key = $this_key->{name};
492
MKDEBUG && $clustered_key && _d('This key is the clustered key');
496
return $keys, $clustered_key;
500
my ( $self, $ddl, $opts ) = @_;
504
$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
506
my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
507
my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
508
my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
510
if ( $parent !~ m/\./ && $opts->{database} ) {
511
$parent = "`$opts->{database}`.$parent";
517
cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
518
parent_tbl => $parent,
519
parent_colnames=> $parent_cols,
520
parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
528
sub remove_auto_increment {
529
my ( $self, $ddl ) = @_;
530
$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
534
sub remove_secondary_indexes {
535
my ( $self, $ddl ) = @_;
537
my $tbl_struct = $self->parse($ddl);
539
if ( ($tbl_struct->{engine} || '') =~ m/InnoDB/i ) {
540
my $clustered_key = $tbl_struct->{clustered_key};
541
$clustered_key ||= '';
543
my @sec_indexes = map {
544
my $key_def = $_->{ddl};
545
$key_def =~ s/([\(\)])/\\$1/g;
546
$ddl =~ s/\s+$key_def//i;
548
my $key_ddl = "ADD $_->{ddl}";
549
$key_ddl .= ',' unless $key_ddl =~ m/,$/;
552
grep { $_->{name} ne $clustered_key }
553
values %{$tbl_struct->{keys}};
554
MKDEBUG && _d('Secondary indexes:', Dumper(\@sec_indexes));
556
if ( @sec_indexes ) {
557
$sec_indexes_ddl = join(' ', @sec_indexes);
558
$sec_indexes_ddl =~ s/,$//;
561
$ddl =~ s/,(\n\) )/$1/s;
564
MKDEBUG && _d('Not removing secondary indexes from',
565
$tbl_struct->{engine}, 'table');
568
return $ddl, $sec_indexes_ddl, $tbl_struct;
572
my ($package, undef, $line) = caller 0;
573
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
574
map { defined $_ ? $_ : 'undef' }
576
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
581
# ###########################################################################
582
# End TableParser package
583
# ###########################################################################
585
# ###########################################################################
586
# MySQLDump package 6345
587
# This package is a copy without comments from the original. The original
588
# with comments and its test file can be found in the SVN repository at,
589
# trunk/common/MySQLDump.pm
590
# trunk/common/t/MySQLDump.t
591
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
592
# ###########################################################################
596
use warnings FATAL => 'all';
598
use English qw(-no_match_vars);
600
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
602
( our $before = <<'EOF') =~ s/^ //gm;
603
/*!40101 SET @OLD_CHARACTER_SET_CLIENT=@@CHARACTER_SET_CLIENT */;
604
/*!40101 SET @OLD_CHARACTER_SET_RESULTS=@@CHARACTER_SET_RESULTS */;
605
/*!40101 SET @OLD_COLLATION_CONNECTION=@@COLLATION_CONNECTION */;
606
/*!40101 SET NAMES utf8 */;
607
/*!40103 SET @OLD_TIME_ZONE=@@TIME_ZONE */;
608
/*!40103 SET TIME_ZONE='+00:00' */;
609
/*!40014 SET @OLD_UNIQUE_CHECKS=@@UNIQUE_CHECKS, UNIQUE_CHECKS=0 */;
610
/*!40014 SET @OLD_FOREIGN_KEY_CHECKS=@@FOREIGN_KEY_CHECKS, FOREIGN_KEY_CHECKS=0 */;
611
/*!40101 SET @OLD_SQL_MODE=@@SQL_MODE, SQL_MODE='NO_AUTO_VALUE_ON_ZERO' */;
612
/*!40111 SET @OLD_SQL_NOTES=@@SQL_NOTES, SQL_NOTES=0 */;
615
( our $after = <<'EOF') =~ s/^ //gm;
616
/*!40103 SET TIME_ZONE=@OLD_TIME_ZONE */;
617
/*!40101 SET SQL_MODE=@OLD_SQL_MODE */;
618
/*!40014 SET FOREIGN_KEY_CHECKS=@OLD_FOREIGN_KEY_CHECKS */;
619
/*!40014 SET UNIQUE_CHECKS=@OLD_UNIQUE_CHECKS */;
620
/*!40101 SET CHARACTER_SET_CLIENT=@OLD_CHARACTER_SET_CLIENT */;
621
/*!40101 SET CHARACTER_SET_RESULTS=@OLD_CHARACTER_SET_RESULTS */;
622
/*!40101 SET COLLATION_CONNECTION=@OLD_COLLATION_CONNECTION */;
623
/*!40111 SET SQL_NOTES=@OLD_SQL_NOTES */;
627
my ( $class, %args ) = @_;
629
cache => 0, # Afaik no script uses this cache any longer because
631
return bless $self, $class;
635
my ( $self, $dbh, $quoter, $db, $tbl, $what ) = @_;
637
if ( $what eq 'table' ) {
638
my $ddl = $self->get_create_table($dbh, $quoter, $db, $tbl);
640
if ( $ddl->[0] eq 'table' ) {
642
. 'DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . ";\n"
646
return 'DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . ";\n"
647
. '/*!50001 DROP VIEW IF EXISTS '
648
. $quoter->quote($tbl) . "*/;\n/*!50001 "
649
. $self->get_tmp_table($dbh, $quoter, $db, $tbl) . "*/;\n";
652
elsif ( $what eq 'triggers' ) {
653
my $trgs = $self->get_triggers($dbh, $quoter, $db, $tbl);
654
if ( $trgs && @$trgs ) {
655
my $result = $before . "\nDELIMITER ;;\n";
656
foreach my $trg ( @$trgs ) {
657
if ( $trg->{sql_mode} ) {
658
$result .= qq{/*!50003 SET SESSION SQL_MODE='$trg->{sql_mode}' */;;\n};
660
$result .= "/*!50003 CREATE */ ";
661
if ( $trg->{definer} ) {
663
= map { s/'/''/g; "'$_'"; }
664
split('@', $trg->{definer}, 2);
665
$result .= "/*!50017 DEFINER=$user\@$host */ ";
667
$result .= sprintf("/*!50003 TRIGGER %s %s %s ON %s\nFOR EACH ROW %s */;;\n\n",
668
$quoter->quote($trg->{trigger}),
669
@{$trg}{qw(timing event)},
670
$quoter->quote($trg->{table}),
673
$result .= "DELIMITER ;\n\n/*!50003 SET SESSION SQL_MODE=\@OLD_SQL_MODE */;\n\n";
680
elsif ( $what eq 'view' ) {
681
my $ddl = $self->get_create_table($dbh, $quoter, $db, $tbl);
682
return '/*!50001 DROP TABLE IF EXISTS ' . $quoter->quote($tbl) . "*/;\n"
683
. '/*!50001 DROP VIEW IF EXISTS ' . $quoter->quote($tbl) . "*/;\n"
684
. '/*!50001 ' . $ddl->[1] . "*/;\n";
687
die "You didn't say what to dump.";
692
my ( $self, $dbh, $quoter, $new ) = @_;
694
MKDEBUG && _d('No new DB to use');
697
my $sql = 'USE ' . $quoter->quote($new);
698
MKDEBUG && _d($dbh, $sql);
703
sub get_create_table {
704
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
705
if ( !$self->{cache} || !$self->{tables}->{$db}->{$tbl} ) {
706
my $sql = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
707
. q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
708
. '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
709
. '@@SQL_QUOTE_SHOW_CREATE := 1 */';
711
eval { $dbh->do($sql); };
712
MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
713
$self->_use_db($dbh, $quoter, $db);
714
$sql = "SHOW CREATE TABLE " . $quoter->quote($db, $tbl);
717
eval { $href = $dbh->selectrow_hashref($sql); };
719
warn "Failed to $sql. The table may be damaged.\nError: $EVAL_ERROR";
723
$sql = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
724
. '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
727
my ($key) = grep { m/create table/i } keys %$href;
729
MKDEBUG && _d('This table is a base table');
730
$self->{tables}->{$db}->{$tbl} = [ 'table', $href->{$key} ];
733
MKDEBUG && _d('This table is a view');
734
($key) = grep { m/create view/i } keys %$href;
735
$self->{tables}->{$db}->{$tbl} = [ 'view', $href->{$key} ];
738
return $self->{tables}->{$db}->{$tbl};
742
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
743
MKDEBUG && _d('Get columns for', $db, $tbl);
744
if ( !$self->{cache} || !$self->{columns}->{$db}->{$tbl} ) {
745
$self->_use_db($dbh, $quoter, $db);
746
my $sql = "SHOW COLUMNS FROM " . $quoter->quote($db, $tbl);
748
my $cols = $dbh->selectall_arrayref($sql, { Slice => {} });
750
$self->{columns}->{$db}->{$tbl} = [
753
@row{ map { lc $_ } keys %$_ } = values %$_;
758
return $self->{columns}->{$db}->{$tbl};
762
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
763
my $result = 'CREATE TABLE ' . $quoter->quote($tbl) . " (\n";
764
$result .= join(",\n",
765
map { ' ' . $quoter->quote($_->{field}) . ' ' . $_->{type} }
766
@{$self->get_columns($dbh, $quoter, $db, $tbl)});
768
MKDEBUG && _d($result);
773
my ( $self, $dbh, $quoter, $db, $tbl ) = @_;
774
if ( !$self->{cache} || !$self->{triggers}->{$db} ) {
775
$self->{triggers}->{$db} = {};
776
my $sql = '/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, '
777
. q{@@SQL_MODE := REPLACE(REPLACE(@@SQL_MODE, 'ANSI_QUOTES', ''), ',,', ','), }
778
. '@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, '
779
. '@@SQL_QUOTE_SHOW_CREATE := 1 */';
781
eval { $dbh->do($sql); };
782
MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
783
$sql = "SHOW TRIGGERS FROM " . $quoter->quote($db);
785
my $sth = $dbh->prepare($sql);
788
my $trgs = $sth->fetchall_arrayref({});
789
foreach my $trg (@$trgs) {
791
@trg{ map { lc $_ } keys %$trg } = values %$trg;
792
push @{ $self->{triggers}->{$db}->{ $trg{table} } }, \%trg;
795
$sql = '/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, '
796
. '@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */';
801
return $self->{triggers}->{$db}->{$tbl};
803
return values %{$self->{triggers}->{$db}};
807
my ( $self, $dbh, $quoter, $like ) = @_;
808
if ( !$self->{cache} || !$self->{databases} || $like ) {
809
my $sql = 'SHOW DATABASES';
815
my $sth = $dbh->prepare($sql);
816
MKDEBUG && _d($sql, @params);
817
$sth->execute( @params );
818
my @dbs = map { $_->[0] } @{$sth->fetchall_arrayref()};
819
$self->{databases} = \@dbs unless $like;
822
return @{$self->{databases}};
825
sub get_table_status {
826
my ( $self, $dbh, $quoter, $db, $like ) = @_;
827
if ( !$self->{cache} || !$self->{table_status}->{$db} || $like ) {
828
my $sql = "SHOW TABLE STATUS FROM " . $quoter->quote($db);
834
MKDEBUG && _d($sql, @params);
835
my $sth = $dbh->prepare($sql);
836
$sth->execute(@params);
837
my @tables = @{$sth->fetchall_arrayref({})};
839
my %tbl; # Make a copy with lowercased keys
840
@tbl{ map { lc $_ } keys %$_ } = values %$_;
841
$tbl{engine} ||= $tbl{type} || $tbl{comment};
845
$self->{table_status}->{$db} = \@tables unless $like;
848
return @{$self->{table_status}->{$db}};
852
my ( $self, $dbh, $quoter, $db, $like ) = @_;
853
if ( !$self->{cache} || !$self->{table_list}->{$db} || $like ) {
854
my $sql = "SHOW /*!50002 FULL*/ TABLES FROM " . $quoter->quote($db);
860
MKDEBUG && _d($sql, @params);
861
my $sth = $dbh->prepare($sql);
862
$sth->execute(@params);
863
my @tables = @{$sth->fetchall_arrayref()};
867
engine => ($_->[1] || '') eq 'VIEW' ? 'VIEW' : '',
871
$self->{table_list}->{$db} = \@tables unless $like;
874
return @{$self->{table_list}->{$db}};
878
my ($package, undef, $line) = caller 0;
879
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
880
map { defined $_ ? $_ : 'undef' }
882
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
887
# ###########################################################################
888
# End MySQLDump package
889
# ###########################################################################
891
# ###########################################################################
892
# DSNParser package 7388
893
# This package is a copy without comments from the original. The original
894
# with comments and its test file can be found in the SVN repository at,
895
# trunk/common/DSNParser.pm
896
# trunk/common/t/DSNParser.t
897
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
898
# ###########################################################################
903
use warnings FATAL => 'all';
904
use English qw(-no_match_vars);
905
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
908
$Data::Dumper::Indent = 0;
909
$Data::Dumper::Quotekeys = 0;
914
my $have_dbi = $EVAL_ERROR ? 0 : 1;
918
my ( $class, %args ) = @_;
919
foreach my $arg ( qw(opts) ) {
920
die "I need a $arg argument" unless $args{$arg};
923
opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
925
foreach my $opt ( @{$args{opts}} ) {
926
if ( !$opt->{key} || !$opt->{desc} ) {
927
die "Invalid DSN option: ", Dumper($opt);
929
MKDEBUG && _d('DSN option:',
931
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
935
$self->{opts}->{$opt->{key}} = {
937
desc => $opt->{desc},
938
copy => $opt->{copy} || 0,
941
return bless $self, $class;
945
my ( $self, $prop, $value ) = @_;
947
MKDEBUG && _d('Setting', $prop, 'property');
948
$self->{$prop} = $value;
950
return $self->{$prop};
954
my ( $self, $dsn, $prev, $defaults ) = @_;
956
MKDEBUG && _d('No DSN to parse');
959
MKDEBUG && _d('Parsing', $dsn);
964
my $opts = $self->{opts};
966
foreach my $dsn_part ( split(/,/, $dsn) ) {
967
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
968
$given_props{$prop_key} = $prop_val;
971
MKDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
972
$given_props{h} = $dsn_part;
976
foreach my $key ( keys %$opts ) {
977
MKDEBUG && _d('Finding value for', $key);
978
$final_props{$key} = $given_props{$key};
979
if ( !defined $final_props{$key}
980
&& defined $prev->{$key} && $opts->{$key}->{copy} )
982
$final_props{$key} = $prev->{$key};
983
MKDEBUG && _d('Copying value for', $key, 'from previous DSN');
985
if ( !defined $final_props{$key} ) {
986
$final_props{$key} = $defaults->{$key};
987
MKDEBUG && _d('Copying value for', $key, 'from defaults');
991
foreach my $key ( keys %given_props ) {
992
die "Unknown DSN option '$key' in '$dsn'. For more details, "
993
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
994
. "for complete documentation."
995
unless exists $opts->{$key};
997
if ( (my $required = $self->prop('required')) ) {
998
foreach my $key ( keys %$required ) {
999
die "Missing required DSN option '$key' in '$dsn'. For more details, "
1000
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
1001
. "for complete documentation."
1002
unless $final_props{$key};
1006
return \%final_props;
1010
my ( $self, $o ) = @_;
1011
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
1014
map { "$_=".$o->get($_); }
1015
grep { $o->has($_) && $o->get($_) }
1016
keys %{$self->{opts}}
1018
MKDEBUG && _d('DSN string made from options:', $dsn_string);
1019
return $self->parse($dsn_string);
1023
my ( $self, $dsn, $props ) = @_;
1024
return $dsn unless ref $dsn;
1025
my %allowed = $props ? map { $_=>1 } @$props : ();
1027
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
1028
grep { defined $dsn->{$_} && $self->{opts}->{$_} }
1029
grep { !$props || $allowed{$_} }
1036
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
1037
. " KEY COPY MEANING\n"
1038
. " === ==== =============================================\n";
1039
my %opts = %{$self->{opts}};
1040
foreach my $key ( sort keys %opts ) {
1042
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
1043
. ($opts{$key}->{desc} || '[No description]')
1046
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
1050
sub get_cxn_params {
1051
my ( $self, $info ) = @_;
1053
my %opts = %{$self->{opts}};
1054
my $driver = $self->prop('dbidriver') || '';
1055
if ( $driver eq 'Pg' ) {
1056
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
1057
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
1058
grep { defined $info->{$_} }
1062
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
1063
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
1064
grep { defined $info->{$_} }
1066
. ';mysql_read_default_group=client';
1068
MKDEBUG && _d($dsn);
1069
return ($dsn, $info->{u}, $info->{p});
1073
my ( $self, $dbh, $dsn ) = @_;
1074
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
1075
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
1077
$dsn->{h} ||= $vars->{hostname}->{Value};
1078
$dsn->{S} ||= $vars->{'socket'}->{Value};
1079
$dsn->{P} ||= $vars->{port}->{Value};
1080
$dsn->{u} ||= $user;
1085
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
1091
ShowErrorStatement => 1,
1092
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
1094
@{$defaults}{ keys %$opts } = values %$opts;
1096
if ( $opts->{mysql_use_result} ) {
1097
$defaults->{mysql_use_result} = 1;
1101
die "Cannot connect to MySQL because the Perl DBI module is not "
1102
. "installed or not found. Run 'perl -MDBI' to see the directories "
1103
. "that Perl searches for DBI. If DBI is not installed, try:\n"
1104
. " Debian/Ubuntu apt-get install libdbi-perl\n"
1105
. " RHEL/CentOS yum install perl-DBI\n"
1106
. " OpenSolaris pgk install pkg:/SUNWpmdbi\n";
1112
while ( !$dbh && $tries-- ) {
1113
MKDEBUG && _d($cxn_string, ' ', $user, ' ', $pass, ' {',
1114
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ), '}');
1117
$dbh = DBI->connect($cxn_string, $user, $pass, $defaults);
1119
if ( $cxn_string =~ m/mysql/i ) {
1122
$sql = 'SELECT @@SQL_MODE';
1123
MKDEBUG && _d($dbh, $sql);
1124
my ($sql_mode) = $dbh->selectrow_array($sql);
1126
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
1127
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
1128
. ($sql_mode ? ",$sql_mode" : '')
1130
MKDEBUG && _d($dbh, $sql);
1133
if ( my ($charset) = $cxn_string =~ m/charset=(\w+)/ ) {
1134
$sql = "/*!40101 SET NAMES $charset*/";
1135
MKDEBUG && _d($dbh, ':', $sql);
1137
MKDEBUG && _d('Enabling charset for STDOUT');
1138
if ( $charset eq 'utf8' ) {
1139
binmode(STDOUT, ':utf8')
1140
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
1143
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
1147
if ( $self->prop('set-vars') ) {
1148
$sql = "SET " . $self->prop('set-vars');
1149
MKDEBUG && _d($dbh, ':', $sql);
1154
if ( !$dbh && $EVAL_ERROR ) {
1155
MKDEBUG && _d($EVAL_ERROR);
1156
if ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
1157
MKDEBUG && _d('Going to try again without utf8 support');
1158
delete $defaults->{mysql_enable_utf8};
1160
elsif ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
1161
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
1162
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
1163
. "the directories that Perl searches for DBD::mysql. If "
1164
. "DBD::mysql is not installed, try:\n"
1165
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
1166
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
1167
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
1175
MKDEBUG && _d('DBH info: ',
1177
Dumper($dbh->selectrow_hashref(
1178
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
1179
'Connection info:', $dbh->{mysql_hostinfo},
1180
'Character set info:', Dumper($dbh->selectall_arrayref(
1181
'SHOW VARIABLES LIKE "character_set%"', { Slice => {}})),
1182
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
1183
'$DBI::VERSION:', $DBI::VERSION,
1190
my ( $self, $dbh ) = @_;
1191
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
1194
my ( $hostname, $one ) = $dbh->selectrow_array(
1195
'SELECT /*!50038 @@hostname, */ 1');
1200
my ( $self, $dbh ) = @_;
1201
MKDEBUG && $self->print_active_handles($dbh);
1205
sub print_active_handles {
1206
my ( $self, $thing, $level ) = @_;
1208
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
1209
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
1210
or die "Cannot print: $OS_ERROR";
1211
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
1212
$self->print_active_handles( $handle, $level + 1 );
1217
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
1218
die 'I need a dsn_1 argument' unless $dsn_1;
1219
die 'I need a dsn_2 argument' unless $dsn_2;
1223
if ( $args{overwrite} ) {
1224
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
1227
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
1230
} keys %{$self->{opts}};
1235
my ($package, undef, $line) = caller 0;
1236
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
1237
map { defined $_ ? $_ : 'undef' }
1239
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
1244
# ###########################################################################
1245
# End DSNParser package
1246
# ###########################################################################
1248
# ###########################################################################
1249
# OptionParser package 7102
1250
# This package is a copy without comments from the original. The original
1251
# with comments and its test file can be found in the SVN repository at,
1252
# trunk/common/OptionParser.pm
1253
# trunk/common/t/OptionParser.t
1254
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
1255
# ###########################################################################
1257
package OptionParser;
1260
use warnings FATAL => 'all';
1261
use List::Util qw(max);
1262
use English qw(-no_match_vars);
1263
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
1267
my $POD_link_re = '[LC]<"?([^">]+)"?>';
1270
my ( $class, %args ) = @_;
1271
my @required_args = qw();
1272
foreach my $arg ( @required_args ) {
1273
die "I need a $arg argument" unless $args{$arg};
1276
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
1277
$program_name ||= $PROGRAM_NAME;
1278
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
1290
head1 => 'OPTIONS', # These args are used internally
1291
skip_rules => 0, # to instantiate another Option-
1292
item => '--(.*)', # Parser obj that parses the
1293
attributes => \%attributes, # DSN OPTIONS section. Tools
1294
parse_attributes => \&_parse_attribs, # don't tinker with these args.
1298
strict => 1, # disabled by a special rule
1299
program_name => $program_name,
1305
allowed_groups => {},
1307
rules => [], # desc of rules for --help
1308
mutex => [], # rule: opts are mutually exclusive
1309
atleast1 => [], # rule: at least one opt is required
1310
disables => {}, # rule: opt disables other opts
1311
defaults_to => {}, # rule: opt defaults to value of other opt
1314
"/etc/maatkit/maatkit.conf",
1315
"/etc/maatkit/$program_name.conf",
1316
"$home/.maatkit.conf",
1317
"$home/.$program_name.conf",
1320
string => 's', # standard Getopt type
1321
int => 'i', # standard Getopt type
1322
float => 'f', # standard Getopt type
1323
Hash => 'H', # hash, formed from a comma-separated list
1324
hash => 'h', # hash as above, but only if a value is given
1325
Array => 'A', # array, similar to Hash
1326
array => 'a', # array, similar to hash
1328
size => 'z', # size with kMG suffix (powers of 2^10)
1329
time => 'm', # time, with an optional suffix of s/h/m/d
1333
return bless $self, $class;
1337
my ( $self, $file ) = @_;
1338
$file ||= $self->{file} || __FILE__;
1339
my @specs = $self->_pod_to_specs($file);
1340
$self->_parse_specs(@specs);
1342
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
1343
my $contents = do { local $/ = undef; <$fh> };
1345
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
1346
MKDEBUG && _d('Parsing DSN OPTIONS');
1351
my $parse_dsn_attribs = sub {
1352
my ( $self, $option, $attribs ) = @_;
1354
my $val = $attribs->{$_};
1356
$val = $val eq 'yes' ? 1
1359
$attribs->{$_} = $val;
1367
my $dsn_o = new OptionParser(
1368
description => 'DSN OPTIONS',
1369
head1 => 'DSN OPTIONS',
1370
dsn => 0, # XXX don't infinitely recurse!
1371
item => '\* (.)', # key opts are a single character
1372
skip_rules => 1, # no rules before opts
1373
attributes => $dsn_attribs,
1374
parse_attributes => $parse_dsn_attribs,
1376
my @dsn_opts = map {
1378
key => $_->{spec}->{key},
1379
dsn => $_->{spec}->{dsn},
1380
copy => $_->{spec}->{copy},
1384
} $dsn_o->_pod_to_specs($file);
1385
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
1393
return $self->{DSNParser};
1396
sub get_defaults_files {
1398
return @{$self->{default_files}};
1402
my ( $self, $file ) = @_;
1403
$file ||= $self->{file} || __FILE__;
1404
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
1410
local $INPUT_RECORD_SEPARATOR = '';
1411
while ( $para = <$fh> ) {
1412
next unless $para =~ m/^=head1 $self->{head1}/;
1416
while ( $para = <$fh> ) {
1417
last if $para =~ m/^=over/;
1418
next if $self->{skip_rules};
1421
$para =~ s/$POD_link_re/$1/go;
1422
MKDEBUG && _d('Option rule:', $para);
1426
die "POD has no $self->{head1} section" unless $para;
1429
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
1431
MKDEBUG && _d($para);
1434
$para = <$fh>; # read next paragraph, possibly attributes
1436
if ( $para =~ m/: / ) { # attributes
1437
$para =~ s/\s+\Z//g;
1439
my ( $attrib, $val) = split(/: /, $_);
1440
die "Unrecognized attribute for --$option: $attrib"
1441
unless $self->{attributes}->{$attrib};
1443
} split(/; /, $para);
1444
if ( $attribs{'short form'} ) {
1445
$attribs{'short form'} =~ s/-//;
1447
$para = <$fh>; # read next paragraph, probably short help desc
1450
MKDEBUG && _d('Option has no attributes');
1453
$para =~ s/\s+\Z//g;
1455
$para =~ s/$POD_link_re/$1/go;
1457
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
1458
MKDEBUG && _d('Short help:', $para);
1460
die "No description after option spec $option" if $para =~ m/^=item/;
1462
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
1463
$option = $base_option;
1464
$attribs{'negatable'} = 1;
1468
spec => $self->{parse_attributes}->($self, $option, \%attribs),
1470
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
1471
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
1474
while ( $para = <$fh> ) {
1476
if ( $para =~ m/^=head1/ ) {
1477
$para = undef; # Can't 'last' out of a do {} block.
1480
last if $para =~ m/^=item /;
1484
die "No valid specs in $self->{head1}" unless @specs;
1487
return @specs, @rules;
1491
my ( $self, @specs ) = @_;
1492
my %disables; # special rule that requires deferred checking
1494
foreach my $opt ( @specs ) {
1495
if ( ref $opt ) { # It's an option spec, not a rule.
1496
MKDEBUG && _d('Parsing opt spec:',
1497
map { ($_, '=>', $opt->{$_}) } keys %$opt);
1499
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
1501
die "Cannot parse long option from spec $opt->{spec}";
1503
$opt->{long} = $long;
1505
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
1506
$self->{opts}->{$long} = $opt;
1508
if ( length $long == 1 ) {
1509
MKDEBUG && _d('Long opt', $long, 'looks like short opt');
1510
$self->{short_opts}->{$long} = $long;
1514
die "Duplicate short option -$short"
1515
if exists $self->{short_opts}->{$short};
1516
$self->{short_opts}->{$short} = $long;
1517
$opt->{short} = $short;
1520
$opt->{short} = undef;
1523
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
1524
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
1525
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
1527
$opt->{group} ||= 'default';
1528
$self->{groups}->{ $opt->{group} }->{$long} = 1;
1530
$opt->{value} = undef;
1533
my ( $type ) = $opt->{spec} =~ m/=(.)/;
1534
$opt->{type} = $type;
1535
MKDEBUG && _d($long, 'type:', $type);
1538
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
1540
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
1541
$self->{defaults}->{$long} = defined $def ? $def : 1;
1542
MKDEBUG && _d($long, 'default:', $def);
1545
if ( $long eq 'config' ) {
1546
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
1549
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
1550
$disables{$long} = $dis;
1551
MKDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
1554
$self->{opts}->{$long} = $opt;
1556
else { # It's an option rule, not a spec.
1557
MKDEBUG && _d('Parsing rule:', $opt);
1558
push @{$self->{rules}}, $opt;
1559
my @participants = $self->_get_participants($opt);
1562
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
1564
push @{$self->{mutex}}, \@participants;
1565
MKDEBUG && _d(@participants, 'are mutually exclusive');
1567
if ( $opt =~ m/at least one|one and only one/ ) {
1569
push @{$self->{atleast1}}, \@participants;
1570
MKDEBUG && _d(@participants, 'require at least one');
1572
if ( $opt =~ m/default to/ ) {
1574
$self->{defaults_to}->{$participants[0]} = $participants[1];
1575
MKDEBUG && _d($participants[0], 'defaults to', $participants[1]);
1577
if ( $opt =~ m/restricted to option groups/ ) {
1579
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
1580
my @groups = split(',', $groups);
1581
%{$self->{allowed_groups}->{$participants[0]}} = map {
1586
if( $opt =~ m/accepts additional command-line arguments/ ) {
1588
$self->{strict} = 0;
1589
MKDEBUG && _d("Strict mode disabled by rule");
1592
die "Unrecognized option rule: $opt" unless $rule_ok;
1596
foreach my $long ( keys %disables ) {
1597
my @participants = $self->_get_participants($disables{$long});
1598
$self->{disables}->{$long} = \@participants;
1599
MKDEBUG && _d('Option', $long, 'disables', @participants);
1605
sub _get_participants {
1606
my ( $self, $str ) = @_;
1608
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
1609
die "Option --$long does not exist while processing rule $str"
1610
unless exists $self->{opts}->{$long};
1611
push @participants, $long;
1613
MKDEBUG && _d('Participants for', $str, ':', @participants);
1614
return @participants;
1619
my %opts = %{$self->{opts}};
1625
my %short_opts = %{$self->{short_opts}};
1630
my ( $self, %defaults ) = @_;
1631
$self->{defaults} = {};
1632
foreach my $long ( keys %defaults ) {
1633
die "Cannot set default for nonexistent option $long"
1634
unless exists $self->{opts}->{$long};
1635
$self->{defaults}->{$long} = $defaults{$long};
1636
MKDEBUG && _d('Default val for', $long, ':', $defaults{$long});
1643
return $self->{defaults};
1648
return $self->{groups};
1652
my ( $self, $opt, $val ) = @_;
1653
my $long = exists $self->{opts}->{$opt} ? $opt
1654
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
1655
: die "Getopt::Long gave a nonexistent option: $opt";
1657
$opt = $self->{opts}->{$long};
1658
if ( $opt->{is_cumulative} ) {
1662
$opt->{value} = $val;
1665
MKDEBUG && _d('Got option', $long, '=', $val);
1671
foreach my $long ( keys %{$self->{opts}} ) {
1672
$self->{opts}->{$long}->{got} = 0;
1673
$self->{opts}->{$long}->{value}
1674
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
1675
: $self->{opts}->{$long}->{is_cumulative} ? 0
1678
$self->{got_opts} = 0;
1680
$self->{errors} = [];
1682
if ( @ARGV && $ARGV[0] eq "--config" ) {
1684
$self->_set_option('config', shift @ARGV);
1686
if ( $self->has('config') ) {
1688
foreach my $filename ( split(',', $self->get('config')) ) {
1690
push @extra_args, $self->_read_config_file($filename);
1692
if ( $EVAL_ERROR ) {
1693
if ( $self->got('config') ) {
1701
unshift @ARGV, @extra_args;
1704
Getopt::Long::Configure('no_ignore_case', 'bundling');
1706
map { $_->{spec} => sub { $self->_set_option(@_); } }
1707
grep { $_->{long} ne 'config' } # --config is handled specially above.
1708
values %{$self->{opts}}
1709
) or $self->save_error('Error parsing options');
1711
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
1712
printf("%s Ver %s Distrib %s Changeset %s\n",
1713
$self->{program_name}, $main::VERSION, $main::DISTRIB, $main::SVN_REV)
1714
or die "Cannot print: $OS_ERROR";
1718
if ( @ARGV && $self->{strict} ) {
1719
$self->save_error("Unrecognized command-line options @ARGV");
1722
foreach my $mutex ( @{$self->{mutex}} ) {
1723
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
1725
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
1726
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
1727
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
1728
. ' are mutually exclusive.';
1729
$self->save_error($err);
1733
foreach my $required ( @{$self->{atleast1}} ) {
1734
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
1736
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
1737
@{$required}[ 0 .. scalar(@$required) - 2] )
1738
.' or --'.$self->{opts}->{$required->[-1]}->{long};
1739
$self->save_error("Specify at least one of $err");
1743
$self->_check_opts( keys %{$self->{opts}} );
1744
$self->{got_opts} = 1;
1749
my ( $self, @long ) = @_;
1750
my $long_last = scalar @long;
1752
foreach my $i ( 0..$#long ) {
1753
my $long = $long[$i];
1755
my $opt = $self->{opts}->{$long};
1756
if ( $opt->{got} ) {
1757
if ( exists $self->{disables}->{$long} ) {
1758
my @disable_opts = @{$self->{disables}->{$long}};
1759
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
1760
MKDEBUG && _d('Unset options', @disable_opts,
1761
'because', $long,'disables them');
1764
if ( exists $self->{allowed_groups}->{$long} ) {
1766
my @restricted_groups = grep {
1767
!exists $self->{allowed_groups}->{$long}->{$_}
1768
} keys %{$self->{groups}};
1770
my @restricted_opts;
1771
foreach my $restricted_group ( @restricted_groups ) {
1773
foreach my $restricted_opt (
1774
keys %{$self->{groups}->{$restricted_group}} )
1776
next RESTRICTED_OPT if $restricted_opt eq $long;
1777
push @restricted_opts, $restricted_opt
1778
if $self->{opts}->{$restricted_opt}->{got};
1782
if ( @restricted_opts ) {
1784
if ( @restricted_opts == 1 ) {
1785
$err = "--$restricted_opts[0]";
1789
map { "--$self->{opts}->{$_}->{long}" }
1791
@restricted_opts[0..scalar(@restricted_opts) - 2]
1793
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
1795
$self->save_error("--$long is not allowed with $err");
1800
elsif ( $opt->{is_required} ) {
1801
$self->save_error("Required option --$long must be specified");
1804
$self->_validate_type($opt);
1805
if ( $opt->{parsed} ) {
1809
MKDEBUG && _d('Temporarily failed to parse', $long);
1813
die "Failed to parse options, possibly due to circular dependencies"
1814
if @long == $long_last;
1821
sub _validate_type {
1822
my ( $self, $opt ) = @_;
1825
if ( !$opt->{type} ) {
1830
my $val = $opt->{value};
1832
if ( $val && $opt->{type} eq 'm' ) { # type time
1833
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
1834
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
1836
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
1837
$suffix = $s || 's';
1838
MKDEBUG && _d('No suffix given; using', $suffix, 'for',
1839
$opt->{long}, '(value:', $val, ')');
1841
if ( $suffix =~ m/[smhd]/ ) {
1842
$val = $suffix eq 's' ? $num # Seconds
1843
: $suffix eq 'm' ? $num * 60 # Minutes
1844
: $suffix eq 'h' ? $num * 3600 # Hours
1845
: $num * 86400; # Days
1846
$opt->{value} = ($prefix || '') . $val;
1847
MKDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
1850
$self->save_error("Invalid time suffix for --$opt->{long}");
1853
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
1854
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
1856
my $from_key = $self->{defaults_to}->{ $opt->{long} };
1858
MKDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
1859
if ( $self->{opts}->{$from_key}->{parsed} ) {
1860
$prev = $self->{opts}->{$from_key}->{value};
1863
MKDEBUG && _d('Cannot parse', $opt->{long}, 'until',
1864
$from_key, 'parsed');
1868
my $defaults = $self->{DSNParser}->parse_options($self);
1869
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
1871
elsif ( $val && $opt->{type} eq 'z' ) { # type size
1872
MKDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
1873
$self->_parse_size($opt, $val);
1875
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
1876
$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val || '')) };
1878
elsif ( $opt->{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
1879
$opt->{value} = [ split(/(?<!\\),\s*/, ($val || '')) ];
1882
MKDEBUG && _d('Nothing to validate for option',
1883
$opt->{long}, 'type', $opt->{type}, 'value', $val);
1891
my ( $self, $opt ) = @_;
1892
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1893
die "Option $opt does not exist"
1894
unless $long && exists $self->{opts}->{$long};
1895
return $self->{opts}->{$long}->{value};
1899
my ( $self, $opt ) = @_;
1900
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1901
die "Option $opt does not exist"
1902
unless $long && exists $self->{opts}->{$long};
1903
return $self->{opts}->{$long}->{got};
1907
my ( $self, $opt ) = @_;
1908
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1909
return defined $long ? exists $self->{opts}->{$long} : 0;
1913
my ( $self, $opt, $val ) = @_;
1914
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
1915
die "Option $opt does not exist"
1916
unless $long && exists $self->{opts}->{$long};
1917
$self->{opts}->{$long}->{value} = $val;
1922
my ( $self, $error ) = @_;
1923
push @{$self->{errors}}, $error;
1929
return $self->{errors};
1934
warn "No usage string is set" unless $self->{usage}; # XXX
1935
return "Usage: " . ($self->{usage} || '') . "\n";
1940
warn "No description string is set" unless $self->{description}; # XXX
1941
my $descr = ($self->{description} || $self->{program_name} || '')
1942
. " For more details, please use the --help option, "
1943
. "or try 'perldoc $PROGRAM_NAME' "
1944
. "for complete documentation.";
1945
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
1946
unless $ENV{DONT_BREAK_LINES};
1947
$descr =~ s/ +$//mg;
1951
sub usage_or_errors {
1952
my ( $self, $file, $return ) = @_;
1953
$file ||= $self->{file} || __FILE__;
1955
if ( !$self->{description} || !$self->{usage} ) {
1956
MKDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
1957
my %synop = $self->_parse_synopsis($file);
1958
$self->{description} ||= $synop{description};
1959
$self->{usage} ||= $synop{usage};
1960
MKDEBUG && _d("Description:", $self->{description},
1961
"\nUsage:", $self->{usage});
1964
if ( $self->{opts}->{help}->{got} ) {
1965
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
1966
exit 0 unless $return;
1968
elsif ( scalar @{$self->{errors}} ) {
1969
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
1970
exit 0 unless $return;
1978
my $usage = $self->usage() . "\n";
1979
if ( (my @errors = @{$self->{errors}}) ) {
1980
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
1983
return $usage . "\n" . $self->descr();
1988
die "Run get_opts() before print_usage()" unless $self->{got_opts};
1989
my @opts = values %{$self->{opts}};
1993
length($_->{long}) # option long name
1994
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
1995
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
2002
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
2003
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
2005
values %{$self->{short_opts}});
2007
my $lcol = max($maxl, ($maxs + 3));
2008
my $rcol = 80 - $lcol - 6;
2009
my $rpad = ' ' x ( 80 - $rcol );
2011
$maxs = max($lcol - 3, $maxs);
2013
my $usage = $self->descr() . "\n" . $self->usage();
2015
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
2016
push @groups, 'default';
2018
foreach my $group ( reverse @groups ) {
2019
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
2021
sort { $a->{long} cmp $b->{long} }
2022
grep { $_->{group} eq $group }
2025
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
2026
my $short = $opt->{short};
2027
my $desc = $opt->{desc};
2029
$long .= $opt->{type} ? "=$opt->{type}" : "";
2031
if ( $opt->{type} && $opt->{type} eq 'm' ) {
2032
my ($s) = $desc =~ m/\(suffix (.)\)/;
2034
$desc =~ s/\s+\(suffix .\)//;
2035
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
2036
. "d=days; if no suffix, $s is used.";
2038
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol})(?:\s+|$)/g);
2041
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
2044
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
2049
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
2051
if ( (my @rules = @{$self->{rules}}) ) {
2052
$usage .= "\nRules:\n\n";
2053
$usage .= join("\n", map { " $_" } @rules) . "\n";
2055
if ( $self->{DSNParser} ) {
2056
$usage .= "\n" . $self->{DSNParser}->usage();
2058
$usage .= "\nOptions and values after processing arguments:\n\n";
2059
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
2060
my $val = $opt->{value};
2061
my $type = $opt->{type} || '';
2062
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
2063
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
2064
: !defined $val ? '(No value)'
2065
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
2066
: $type =~ m/H|h/ ? join(',', sort keys %$val)
2067
: $type =~ m/A|a/ ? join(',', @$val)
2069
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
2075
shift @_ if ref $_[0] eq __PACKAGE__;
2076
my ( $prompt ) = @_;
2077
local $OUTPUT_AUTOFLUSH = 1;
2079
or die "Cannot print: $OS_ERROR";
2082
require Term::ReadKey;
2083
Term::ReadKey::ReadMode('noecho');
2084
chomp($response = <STDIN>);
2085
Term::ReadKey::ReadMode('normal');
2087
or die "Cannot print: $OS_ERROR";
2089
if ( $EVAL_ERROR ) {
2090
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
2096
print '# ', $^X, ' ', $], "\n";
2097
my $uname = `uname -a`;
2099
$uname =~ s/\s+/ /g;
2102
printf("# %s Ver %s Distrib %s Changeset %s line %d\n",
2103
$PROGRAM_NAME, ($main::VERSION || ''), ($main::DISTRIB || ''),
2104
($main::SVN_REV || ''), __LINE__);
2105
print('# Arguments: ',
2106
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n");
2109
sub _read_config_file {
2110
my ( $self, $filename ) = @_;
2111
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
2117
while ( my $line = <$fh> ) {
2119
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
2120
$line =~ s/\s+#.*$//g;
2121
$line =~ s/^\s+|\s+$//g;
2122
if ( $line eq '--' ) {
2128
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
2130
push @args, grep { defined $_ } ("$prefix$opt", $arg);
2132
elsif ( $line =~ m/./ ) {
2136
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
2143
sub read_para_after {
2144
my ( $self, $file, $regex ) = @_;
2145
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
2146
local $INPUT_RECORD_SEPARATOR = '';
2148
while ( $para = <$fh> ) {
2149
next unless $para =~ m/^=pod$/m;
2152
while ( $para = <$fh> ) {
2153
next unless $para =~ m/$regex/;
2158
close $fh or die "Can't close $file: $OS_ERROR";
2166
my $hashref = $self->{$_};
2168
foreach my $key ( keys %$hashref ) {
2169
my $ref = ref $hashref->{$key};
2170
$val_copy->{$key} = !$ref ? $hashref->{$key}
2171
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
2172
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
2176
} qw(opts short_opts defaults);
2178
foreach my $scalar ( qw(got_opts) ) {
2179
$clone{$scalar} = $self->{$scalar};
2182
return bless \%clone;
2186
my ( $self, $opt, $val ) = @_;
2188
if ( lc($val || '') eq 'null' ) {
2189
MKDEBUG && _d('NULL size for', $opt->{long});
2190
$opt->{value} = 'null';
2194
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
2195
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
2196
if ( defined $num ) {
2198
$num *= $factor_for{$factor};
2199
MKDEBUG && _d('Setting option', $opt->{y},
2200
'to num', $num, '* factor', $factor);
2202
$opt->{value} = ($pre || '') . $num;
2205
$self->save_error("Invalid size for --$opt->{long}");
2210
sub _parse_attribs {
2211
my ( $self, $option, $attribs ) = @_;
2212
my $types = $self->{types};
2214
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
2215
. ($attribs->{'negatable'} ? '!' : '' )
2216
. ($attribs->{'cumulative'} ? '+' : '' )
2217
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
2220
sub _parse_synopsis {
2221
my ( $self, $file ) = @_;
2222
$file ||= $self->{file} || __FILE__;
2223
MKDEBUG && _d("Parsing SYNOPSIS in", $file);
2225
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
2226
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
2228
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
2229
die "$file does not contain a SYNOPSIS section" unless $para;
2231
for ( 1..2 ) { # 1 for the usage, 2 for the description
2236
MKDEBUG && _d("Raw SYNOPSIS text:", @synop);
2237
my ($usage, $desc) = @synop;
2238
die "The SYNOPSIS section in $file is not formatted properly"
2239
unless $usage && $desc;
2241
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
2245
$desc =~ s/\s{2,}/ /g;
2246
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
2250
description => $desc,
2256
my ($package, undef, $line) = caller 0;
2257
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2258
map { defined $_ ? $_ : 'undef' }
2260
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2265
# ###########################################################################
2266
# End OptionParser package
2267
# ###########################################################################
2269
# ###########################################################################
2270
# KeySize package 7096
2271
# This package is a copy without comments from the original. The original
2272
# with comments and its test file can be found in the SVN repository at,
2273
# trunk/common/KeySize.pm
2274
# trunk/common/t/KeySize.t
2275
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
2276
# ###########################################################################
2280
use warnings FATAL => 'all';
2281
use English qw(-no_match_vars);
2283
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
2286
my ( $class, %args ) = @_;
2287
my $self = { %args };
2288
return bless $self, $class;
2292
my ( $self, %args ) = @_;
2293
foreach my $arg ( qw(name cols tbl_name tbl_struct dbh) ) {
2294
die "I need a $arg argument" unless $args{$arg};
2296
my $name = $args{name};
2297
my @cols = @{$args{cols}};
2298
my $dbh = $args{dbh};
2300
$self->{explain} = '';
2301
$self->{query} = '';
2302
$self->{error} = '';
2305
$self->{error} = "No columns for key $name";
2309
my $key_exists = $self->_key_exists(%args);
2310
MKDEBUG && _d('Key', $name, 'exists in', $args{tbl_name}, ':',
2311
$key_exists ? 'yes': 'no');
2313
my $sql = 'EXPLAIN SELECT ' . join(', ', @cols)
2314
. ' FROM ' . $args{tbl_name}
2315
. ($key_exists ? " FORCE INDEX (`$name`)" : '')
2318
foreach my $col ( @cols ) {
2319
push @where_cols, "$col=1";
2321
if ( scalar @cols == 1 ) {
2322
push @where_cols, "$cols[0]<>1";
2324
$sql .= join(' OR ', @where_cols);
2325
$self->{query} = $sql;
2326
MKDEBUG && _d('sql:', $sql);
2329
my $sth = $dbh->prepare($sql);
2330
eval { $sth->execute(); };
2331
if ( $EVAL_ERROR ) {
2333
$self->{error} = "Cannot get size of $name key: $EVAL_ERROR";
2336
$explain = $sth->fetchrow_hashref();
2338
$self->{explain} = $explain;
2339
my $key_len = $explain->{key_len};
2340
my $rows = $explain->{rows};
2341
my $chosen_key = $explain->{key}; # May differ from $name
2342
MKDEBUG && _d('MySQL chose key:', $chosen_key, 'len:', $key_len,
2346
if ( $key_len && $rows ) {
2347
if ( $chosen_key =~ m/,/ && $key_len =~ m/,/ ) {
2348
$self->{error} = "MySQL chose multiple keys: $chosen_key";
2351
$key_size = $key_len * $rows;
2354
$self->{error} = "key_len or rows NULL in EXPLAIN:\n"
2355
. _explain_to_text($explain);
2359
return $key_size, $chosen_key;
2364
return $self->{query};
2369
return _explain_to_text($self->{explain});
2374
return $self->{error};
2378
my ( $self, %args ) = @_;
2379
return exists $args{tbl_struct}->{keys}->{ lc $args{name} } ? 1 : 0;
2382
sub _explain_to_text {
2383
my ( $explain ) = @_;
2385
map { "$_: ".($explain->{$_} ? $explain->{$_} : 'NULL') }
2391
my ($package, undef, $line) = caller 0;
2392
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2393
map { defined $_ ? $_ : 'undef' }
2395
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2400
# ###########################################################################
2401
# End KeySize package
2402
# ###########################################################################
2404
# ###########################################################################
2405
# DuplicateKeyFinder package 7147
2406
# This package is a copy without comments from the original. The original
2407
# with comments and its test file can be found in the SVN repository at,
2408
# trunk/common/DuplicateKeyFinder.pm
2409
# trunk/common/t/DuplicateKeyFinder.t
2410
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
2411
# ###########################################################################
2412
package DuplicateKeyFinder;
2415
use warnings FATAL => 'all';
2416
use English qw(-no_match_vars);
2418
use List::Util qw(min);
2420
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
2423
my ( $class, %args ) = @_;
2425
return bless $self, $class;
2428
sub get_duplicate_keys {
2429
my ( $self, $keys, %args ) = @_;
2430
die "I need a keys argument" unless $keys;
2431
my %keys = %$keys; # Copy keys because we remove non-duplicates.
2439
foreach my $key ( values %keys ) {
2440
$key->{real_cols} = [ @{$key->{cols}} ];
2442
$key->{len_cols} = length $key->{colnames};
2444
if ( $key->{name} eq 'PRIMARY'
2445
|| ($args{clustered_key} && $key->{name} eq $args{clustered_key}) ) {
2446
$primary_key = $key;
2447
MKDEBUG && _d('primary key:', $key->{name});
2451
my $is_fulltext = $key->{type} eq 'FULLTEXT' ? 1 : 0;
2452
if ( $args{ignore_order} || $is_fulltext ) {
2453
my $ordered_cols = join(',', sort(split(/,/, $key->{colnames})));
2454
MKDEBUG && _d('Reordered', $key->{name}, 'cols from',
2455
$key->{colnames}, 'to', $ordered_cols);
2456
$key->{colnames} = $ordered_cols;
2459
my $push_to = $key->{is_unique} ? \@unique_keys : \@normal_keys;
2460
if ( !$args{ignore_structure} ) {
2461
$push_to = \@fulltext_keys if $is_fulltext;
2463
push @$push_to, $key;
2466
push @normal_keys, $self->unconstrain_keys($primary_key, \@unique_keys);
2468
if ( $primary_key ) {
2469
MKDEBUG && _d('Comparing PRIMARY KEY to UNIQUE keys');
2471
$self->remove_prefix_duplicates([$primary_key], \@unique_keys, %args);
2473
MKDEBUG && _d('Comparing PRIMARY KEY to normal keys');
2475
$self->remove_prefix_duplicates([$primary_key], \@normal_keys, %args);
2478
MKDEBUG && _d('Comparing UNIQUE keys to normal keys');
2480
$self->remove_prefix_duplicates(\@unique_keys, \@normal_keys, %args);
2482
MKDEBUG && _d('Comparing normal keys');
2484
$self->remove_prefix_duplicates(\@normal_keys, \@normal_keys, %args);
2486
MKDEBUG && _d('Comparing FULLTEXT keys');
2488
$self->remove_prefix_duplicates(\@fulltext_keys, \@fulltext_keys, %args, exact_duplicates => 1);
2491
my $clustered_key = $args{clustered_key} ? $keys{$args{clustered_key}}
2493
MKDEBUG && _d('clustered key:', $clustered_key->{name},
2494
$clustered_key->{colnames});
2497
&& $args{tbl_info}->{engine}
2498
&& $args{tbl_info}->{engine} =~ m/InnoDB/i )
2500
MKDEBUG && _d('Removing UNIQUE dupes of clustered key');
2502
$self->remove_clustered_duplicates($clustered_key, \@unique_keys, %args);
2504
MKDEBUG && _d('Removing ordinary dupes of clustered key');
2506
$self->remove_clustered_duplicates($clustered_key, \@normal_keys, %args);
2512
sub get_duplicate_fks {
2513
my ( $self, $fks, %args ) = @_;
2514
die "I need a fks argument" unless $fks;
2515
my @fks = values %$fks;
2518
foreach my $i ( 0..$#fks - 1 ) {
2519
next unless $fks[$i];
2520
foreach my $j ( $i+1..$#fks ) {
2521
next unless $fks[$j];
2523
my $i_cols = join(',', sort @{$fks[$i]->{cols}} );
2524
my $j_cols = join(',', sort @{$fks[$j]->{cols}} );
2525
my $i_pcols = join(',', sort @{$fks[$i]->{parent_cols}} );
2526
my $j_pcols = join(',', sort @{$fks[$j]->{parent_cols}} );
2528
if ( $fks[$i]->{parent_tbl} eq $fks[$j]->{parent_tbl}
2529
&& $i_cols eq $j_cols
2530
&& $i_pcols eq $j_pcols ) {
2532
key => $fks[$j]->{name},
2533
cols => [ @{$fks[$j]->{cols}} ],
2534
ddl => $fks[$j]->{ddl},
2535
duplicate_of => $fks[$i]->{name},
2536
duplicate_of_cols => [ @{$fks[$i]->{cols}} ],
2537
duplicate_of_ddl => $fks[$i]->{ddl},
2539
"FOREIGN KEY $fks[$j]->{name} ($fks[$j]->{colnames}) "
2540
. "REFERENCES $fks[$j]->{parent_tbl} "
2541
. "($fks[$j]->{parent_colnames}) "
2542
. 'is a duplicate of '
2543
. "FOREIGN KEY $fks[$i]->{name} ($fks[$i]->{colnames}) "
2544
. "REFERENCES $fks[$i]->{parent_tbl} "
2545
."($fks[$i]->{parent_colnames})",
2550
$args{callback}->($dupe, %args) if $args{callback};
2557
sub remove_prefix_duplicates {
2558
my ( $self, $left_keys, $right_keys, %args ) = @_;
2562
my $last_right_key = scalar(@$right_keys) - 1;
2565
if ( $right_keys != $left_keys ) {
2567
@$left_keys = sort { lc($a->{colnames}) cmp lc($b->{colnames}) }
2568
grep { defined $_; }
2570
@$right_keys = sort { lc($a->{colnames}) cmp lc($b->{colnames}) }
2571
grep { defined $_; }
2574
$last_left_key = scalar(@$left_keys) - 1;
2580
@$left_keys = reverse sort { lc($a->{colnames}) cmp lc($b->{colnames}) }
2581
grep { defined $_; }
2584
$last_left_key = scalar(@$left_keys) - 2;
2590
foreach my $left_index ( 0..$last_left_key ) {
2591
next LEFT_KEY unless defined $left_keys->[$left_index];
2594
foreach my $right_index ( $left_index+$right_offset..$last_right_key ) {
2595
next RIGHT_KEY unless defined $right_keys->[$right_index];
2597
my $left_name = $left_keys->[$left_index]->{name};
2598
my $left_cols = $left_keys->[$left_index]->{colnames};
2599
my $left_len_cols = $left_keys->[$left_index]->{len_cols};
2600
my $right_name = $right_keys->[$right_index]->{name};
2601
my $right_cols = $right_keys->[$right_index]->{colnames};
2602
my $right_len_cols = $right_keys->[$right_index]->{len_cols};
2604
MKDEBUG && _d('Comparing left', $left_name, '(',$left_cols,')',
2605
'to right', $right_name, '(',$right_cols,')');
2607
if ( substr($left_cols, 0, $right_len_cols)
2608
eq substr($right_cols, 0, $right_len_cols) ) {
2610
if ( $args{exact_duplicates} && ($right_len_cols<$left_len_cols) ) {
2611
MKDEBUG && _d($right_name, 'not exact duplicate of', $left_name);
2615
if ( exists $right_keys->[$right_index]->{unique_col} ) {
2616
MKDEBUG && _d('Cannot remove', $right_name,
2617
'because is constrains col',
2618
$right_keys->[$right_index]->{cols}->[0]);
2622
MKDEBUG && _d('Remove', $right_name);
2624
if ( $right_keys->[$right_index]->{unconstrained} ) {
2625
$reason .= "Uniqueness of $right_name ignored because "
2626
. $right_keys->[$right_index]->{constraining_key}->{name}
2627
. " is a stronger constraint\n";
2629
my $exact_dupe = $right_len_cols < $left_len_cols ? 0 : 1;
2630
$reason .= $right_name
2631
. ($exact_dupe ? ' is a duplicate of '
2632
: ' is a left-prefix of ')
2636
cols => $right_keys->[$right_index]->{real_cols},
2637
ddl => $right_keys->[$right_index]->{ddl},
2638
duplicate_of => $left_name,
2639
duplicate_of_cols => $left_keys->[$left_index]->{real_cols},
2640
duplicate_of_ddl => $left_keys->[$left_index]->{ddl},
2642
dupe_type => $exact_dupe ? 'exact' : 'prefix',
2645
delete $right_keys->[$right_index];
2647
$args{callback}->($dupe, %args) if $args{callback};
2650
MKDEBUG && _d($right_name, 'not left-prefix of', $left_name);
2655
MKDEBUG && _d('No more keys');
2657
@$left_keys = grep { defined $_; } @$left_keys;
2658
@$right_keys = grep { defined $_; } @$right_keys;
2663
sub remove_clustered_duplicates {
2664
my ( $self, $ck, $keys, %args ) = @_;
2665
die "I need a ck argument" unless $ck;
2666
die "I need a keys argument" unless $keys;
2667
my $ck_cols = $ck->{colnames};
2671
for my $i ( 0 .. @$keys - 1 ) {
2672
my $key = $keys->[$i]->{colnames};
2673
if ( $key =~ m/$ck_cols$/ ) {
2674
MKDEBUG && _d("clustered key dupe:", $keys->[$i]->{name},
2675
$keys->[$i]->{colnames});
2677
key => $keys->[$i]->{name},
2678
cols => $keys->[$i]->{real_cols},
2679
ddl => $keys->[$i]->{ddl},
2680
duplicate_of => $ck->{name},
2681
duplicate_of_cols => $ck->{real_cols},
2682
duplicate_of_ddl => $ck->{ddl},
2683
reason => "Key $keys->[$i]->{name} ends with a "
2684
. "prefix of the clustered index",
2685
dupe_type => 'clustered',
2686
short_key => $self->shorten_clustered_duplicate(
2688
join(',', map { "`$_`" }
2689
@{$keys->[$i]->{real_cols}})
2694
$args{callback}->($dupe, %args) if $args{callback};
2697
MKDEBUG && _d('No more keys');
2699
@$keys = grep { defined $_; } @$keys;
2704
sub shorten_clustered_duplicate {
2705
my ( $self, $ck_cols, $dupe_key_cols ) = @_;
2706
return $ck_cols if $ck_cols eq $dupe_key_cols;
2707
$dupe_key_cols =~ s/$ck_cols$//;
2708
$dupe_key_cols =~ s/,+$//;
2709
return $dupe_key_cols;
2712
sub unconstrain_keys {
2713
my ( $self, $primary_key, $unique_keys ) = @_;
2714
die "I need a unique_keys argument" unless $unique_keys;
2718
my @unconstrained_keys;
2720
MKDEBUG && _d('Unconstraining redundantly unique keys');
2723
foreach my $unique_key ( $primary_key, @$unique_keys ) {
2724
next unless $unique_key; # primary key may be undefined
2725
my $cols = $unique_key->{cols};
2726
if ( @$cols == 1 ) {
2727
MKDEBUG && _d($unique_key->{name},'defines unique column:',$cols->[0]);
2728
if ( !exists $unique_cols{$cols->[0]} ) {
2729
$unique_cols{$cols->[0]} = $unique_key;
2730
$unique_key->{unique_col} = 1;
2734
local $LIST_SEPARATOR = '-';
2735
MKDEBUG && _d($unique_key->{name}, 'defines unique set:', @$cols);
2736
push @unique_sets, { cols => $cols, key => $unique_key };
2741
foreach my $unique_set ( @unique_sets ) {
2742
my $n_unique_cols = 0;
2744
foreach my $col ( @{$unique_set->{cols}} ) {
2745
if ( exists $unique_cols{$col} ) {
2746
MKDEBUG && _d('Unique set', $unique_set->{key}->{name},
2747
'has unique col', $col);
2748
last COL if ++$n_unique_cols > 1;
2749
$unique_set->{constraining_key} = $unique_cols{$col};
2752
if ( $n_unique_cols && $unique_set->{key}->{name} ne 'PRIMARY' ) {
2753
MKDEBUG && _d('Will unconstrain unique set',
2754
$unique_set->{key}->{name},
2755
'because it is redundantly constrained by key',
2756
$unique_set->{constraining_key}->{name},
2757
'(',$unique_set->{constraining_key}->{colnames},')');
2758
$unconstrain{$unique_set->{key}->{name}}
2759
= $unique_set->{constraining_key};
2763
for my $i ( 0..(scalar @$unique_keys-1) ) {
2764
if ( exists $unconstrain{$unique_keys->[$i]->{name}} ) {
2765
MKDEBUG && _d('Unconstraining', $unique_keys->[$i]->{name});
2766
$unique_keys->[$i]->{unconstrained} = 1;
2767
$unique_keys->[$i]->{constraining_key}
2768
= $unconstrain{$unique_keys->[$i]->{name}};
2769
push @unconstrained_keys, $unique_keys->[$i];
2770
delete $unique_keys->[$i];
2774
MKDEBUG && _d('No more keys');
2775
return @unconstrained_keys;
2779
my ($package, undef, $line) = caller 0;
2780
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
2781
map { defined $_ ? $_ : 'undef' }
2783
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
2787
# ###########################################################################
2788
# End DuplicateKeyFinder package
2789
# ###########################################################################
2791
# ###########################################################################
2792
# Transformers package 7226
2793
# This package is a copy without comments from the original. The original
2794
# with comments and its test file can be found in the SVN repository at,
2795
# trunk/common/Transformers.pm
2796
# trunk/common/t/Transformers.t
2797
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
2798
# ###########################################################################
2800
package Transformers;
2803
use warnings FATAL => 'all';
2804
use English qw(-no_match_vars);
2805
use Time::Local qw(timegm timelocal);
2806
use Digest::MD5 qw(md5_hex);
2808
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
2811
our @ISA = qw(Exporter);
2812
our %EXPORT_TAGS = ();
2814
our @EXPORT_OK = qw(
2828
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
2829
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
2830
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
2833
my ( $t, %args ) = @_;
2834
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
2835
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
2840
$t = sprintf('%.17f', $t) if $t =~ /e/;
2842
$t =~ s/\.(\d{1,6})\d*/\.$1/;
2844
if ($t > 0 && $t <= 0.000999) {
2845
$f = ($t * 1000000) . 'us';
2847
elsif ($t >= 0.001000 && $t <= 0.999999) {
2848
$f = sprintf("%.${p_ms}f", $t * 1000);
2849
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
2852
$f = sprintf("%.${p_s}f", $t);
2853
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
2856
$f = 0; # $t should = 0 at this point
2863
my ( $is, $of, %args ) = @_;
2864
my $p = $args{p} || 0; # float precision
2865
my $fmt = $p ? "%.${p}f" : "%d";
2866
return sprintf $fmt, ($is * 100) / ($of ||= 1);
2870
my ( $secs, $fmt ) = @_;
2872
return '00:00' unless $secs;
2874
$fmt ||= $secs >= 86_400 ? 'd'
2875
: $secs >= 3_600 ? 'h'
2879
$fmt eq 'd' ? sprintf(
2880
"%d+%02d:%02d:%02d",
2881
int($secs / 86_400),
2882
int(($secs % 86_400) / 3_600),
2883
int(($secs % 3_600) / 60),
2885
: $fmt eq 'h' ? sprintf(
2887
int(($secs % 86_400) / 3_600),
2888
int(($secs % 3_600) / 60),
2892
int(($secs % 3_600) / 60),
2897
my ( $val, $default_suffix ) = @_;
2898
die "I need a val argument" unless defined $val;
2900
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
2901
$suffix = $suffix || $default_suffix || 's';
2902
if ( $suffix =~ m/[smhd]/ ) {
2903
$t = $suffix eq 's' ? $num * 1 # Seconds
2904
: $suffix eq 'm' ? $num * 60 # Minutes
2905
: $suffix eq 'h' ? $num * 3600 # Hours
2906
: $num * 86400; # Days
2908
$t *= -1 if $prefix && $prefix eq '-';
2911
die "Invalid suffix for $val: $suffix";
2917
my ( $num, %args ) = @_;
2918
my $p = defined $args{p} ? $args{p} : 2; # float precision
2919
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
2921
my @units = ('', qw(k M G T P E Z Y));
2922
while ( $num >= $d && $n < @units - 1 ) {
2934
my ( $time, $gmt ) = @_;
2935
my ( $sec, $min, $hour, $mday, $mon, $year )
2936
= $gmt ? gmtime($time) : localtime($time);
2939
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
2940
$year, $mon, $mday, $hour, $min, $sec);
2941
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
2942
$us = sprintf("%.6f", $us);
2949
sub parse_timestamp {
2951
if ( my($y, $m, $d, $h, $i, $s, $f)
2952
= $val =~ m/^$mysql_ts$/ )
2954
return sprintf "%d-%02d-%02d %02d:%02d:"
2955
. (defined $f ? '%09.6f' : '%02d'),
2956
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
2961
sub unix_timestamp {
2962
my ( $val, $gmt ) = @_;
2963
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
2965
? timegm($s, $i, $h, $d, $m - 1, $y)
2966
: timelocal($s, $i, $h, $d, $m - 1, $y);
2967
if ( defined $us ) {
2968
$us = sprintf('%.6f', $us);
2976
sub any_unix_timestamp {
2977
my ( $val, $callback ) = @_;
2979
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
2980
$n = $suffix eq 's' ? $n # Seconds
2981
: $suffix eq 'm' ? $n * 60 # Minutes
2982
: $suffix eq 'h' ? $n * 3600 # Hours
2983
: $suffix eq 'd' ? $n * 86400 # Days
2984
: $n; # default: Seconds
2985
MKDEBUG && _d('ts is now - N[shmd]:', $n);
2988
elsif ( $val =~ m/^\d{9,}/ ) {
2989
MKDEBUG && _d('ts is already a unix timestamp');
2992
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
2993
MKDEBUG && _d('ts is MySQL slow log timestamp');
2994
$val .= ' 00:00:00' unless $hms;
2995
return unix_timestamp(parse_timestamp($val));
2997
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
2998
MKDEBUG && _d('ts is properly formatted timestamp');
2999
$val .= ' 00:00:00' unless $hms;
3000
return unix_timestamp($val);
3003
MKDEBUG && _d('ts is MySQL expression');
3004
return $callback->($val) if $callback && ref $callback eq 'CODE';
3007
MKDEBUG && _d('Unknown ts type:', $val);
3013
my $checksum = uc substr(md5_hex($val), -16);
3014
MKDEBUG && _d($checksum, 'checksum for', $val);
3019
my ( $string ) = @_;
3020
return unless $string;
3021
my $poly = 0xEDB88320;
3022
my $crc = 0xFFFFFFFF;
3023
foreach my $char ( split(//, $string) ) {
3024
my $comp = ($crc ^ ord($char)) & 0xFF;
3026
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
3028
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
3030
return $crc ^ 0xFFFFFFFF;
3034
my ($package, undef, $line) = caller 0;
3035
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3036
map { defined $_ ? $_ : 'undef' }
3038
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3043
# ###########################################################################
3044
# End Transformers package
3045
# ###########################################################################
3047
# ###########################################################################
3048
# Daemon package 6255
3049
# This package is a copy without comments from the original. The original
3050
# with comments and its test file can be found in the SVN repository at,
3051
# trunk/common/Daemon.pm
3052
# trunk/common/t/Daemon.t
3053
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
3054
# ###########################################################################
3059
use warnings FATAL => 'all';
3061
use POSIX qw(setsid);
3062
use English qw(-no_match_vars);
3064
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
3067
my ( $class, %args ) = @_;
3068
foreach my $arg ( qw(o) ) {
3069
die "I need a $arg argument" unless $args{$arg};
3074
log_file => $o->has('log') ? $o->get('log') : undef,
3075
PID_file => $o->has('pid') ? $o->get('pid') : undef,
3078
check_PID_file(undef, $self->{PID_file});
3080
MKDEBUG && _d('Daemonized child will log to', $self->{log_file});
3081
return bless $self, $class;
3087
MKDEBUG && _d('About to fork and daemonize');
3088
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
3090
MKDEBUG && _d('I am the parent and now I die');
3094
$self->{PID_owner} = $PID;
3097
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
3098
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
3100
$self->_make_PID_file();
3102
$OUTPUT_AUTOFLUSH = 1;
3106
open STDIN, '/dev/null'
3107
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
3110
if ( $self->{log_file} ) {
3112
open STDOUT, '>>', $self->{log_file}
3113
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
3116
open STDERR, ">&STDOUT"
3117
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
3122
open STDOUT, '>', '/dev/null'
3123
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
3127
open STDERR, '>', '/dev/null'
3128
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
3132
MKDEBUG && _d('I am the child and now I live daemonized');
3136
sub check_PID_file {
3137
my ( $self, $file ) = @_;
3138
my $PID_file = $self ? $self->{PID_file} : $file;
3139
MKDEBUG && _d('Checking PID file', $PID_file);
3140
if ( $PID_file && -f $PID_file ) {
3142
eval { chomp($pid = `cat $PID_file`); };
3143
die "Cannot cat $PID_file: $OS_ERROR" if $EVAL_ERROR;
3144
MKDEBUG && _d('PID file exists; it contains PID', $pid);
3146
my $pid_is_alive = kill 0, $pid;
3147
if ( $pid_is_alive ) {
3148
die "The PID file $PID_file already exists "
3149
. " and the PID that it contains, $pid, is running";
3152
warn "Overwriting PID file $PID_file because the PID that it "
3153
. "contains, $pid, is not running";
3157
die "The PID file $PID_file already exists but it does not "
3162
MKDEBUG && _d('No PID file');
3169
if ( exists $self->{child} ) {
3170
die "Do not call Daemon::make_PID_file() for daemonized scripts";
3172
$self->_make_PID_file();
3173
$self->{PID_owner} = $PID;
3177
sub _make_PID_file {
3180
my $PID_file = $self->{PID_file};
3182
MKDEBUG && _d('No PID file to create');
3186
$self->check_PID_file();
3188
open my $PID_FH, '>', $PID_file
3189
or die "Cannot open PID file $PID_file: $OS_ERROR";
3191
or die "Cannot print to PID file $PID_file: $OS_ERROR";
3193
or die "Cannot close PID file $PID_file: $OS_ERROR";
3195
MKDEBUG && _d('Created PID file:', $self->{PID_file});
3199
sub _remove_PID_file {
3201
if ( $self->{PID_file} && -f $self->{PID_file} ) {
3202
unlink $self->{PID_file}
3203
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
3204
MKDEBUG && _d('Removed PID file');
3207
MKDEBUG && _d('No PID to remove');
3215
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
3221
my ($package, undef, $line) = caller 0;
3222
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3223
map { defined $_ ? $_ : 'undef' }
3225
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3230
# ###########################################################################
3231
# End Daemon package
3232
# ###########################################################################
3234
# ###########################################################################
3235
# SchemaIterator package 7141
3236
# This package is a copy without comments from the original. The original
3237
# with comments and its test file can be found in the SVN repository at,
3238
# trunk/common/SchemaIterator.pm
3239
# trunk/common/t/SchemaIterator.t
3240
# See http://code.google.com/p/maatkit/wiki/Developers for more information.
3241
# ###########################################################################
3242
package SchemaIterator;
3245
use warnings FATAL => 'all';
3247
use English qw(-no_match_vars);
3249
$Data::Dumper::Indent = 1;
3250
$Data::Dumper::Sortkeys = 1;
3251
$Data::Dumper::Quotekeys = 0;
3253
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
3256
my ( $class, %args ) = @_;
3257
foreach my $arg ( qw(Quoter) ) {
3258
die "I need a $arg argument" unless $args{$arg};
3265
return bless $self, $class;
3269
my ( $self, $o ) = @_;
3272
' my ( $dbh, $db, $tbl ) = @_;',
3273
' my $engine = undef;',
3277
my @permit_dbs = _make_filter('unless', '$db', $o->get('databases'))
3278
if $o->has('databases');
3279
my @reject_dbs = _make_filter('if', '$db', $o->get('ignore-databases'))
3280
if $o->has('ignore-databases');
3282
if ( $o->has('databases-regex') && (my $p = $o->get('databases-regex')) ) {
3283
push @dbs_regex, " return 0 unless \$db && (\$db =~ m/$p/o);";
3285
my @reject_dbs_regex;
3286
if ( $o->has('ignore-databases-regex')
3287
&& (my $p = $o->get('ignore-databases-regex')) ) {
3288
push @reject_dbs_regex, " return 0 if \$db && (\$db =~ m/$p/o);";
3290
if ( @permit_dbs || @reject_dbs || @dbs_regex || @reject_dbs_regex ) {
3293
(@permit_dbs ? @permit_dbs : ()),
3294
(@reject_dbs ? @reject_dbs : ()),
3295
(@dbs_regex ? @dbs_regex : ()),
3296
(@reject_dbs_regex ? @reject_dbs_regex : ()),
3300
if ( $o->has('tables') || $o->has('ignore-tables')
3301
|| $o->has('ignore-tables-regex') ) {
3304
my $have_only_qtbls = 0;
3310
if ( $o->get('tables') ) {
3313
if ( $_ =~ m/\./ ) {
3314
$permit_qtbls{$_} = 1;
3319
} keys %{ $o->get('tables') };
3320
@permit_tbls = _make_filter('unless', '$tbl', \%tbls);
3321
@permit_qtbls = _make_filter('unless', '$qtbl', \%permit_qtbls);
3323
if ( @permit_qtbls ) {
3325
' my $qtbl = ($db ? "$db." : "") . ($tbl ? $tbl : "");';
3333
if ( $o->get('ignore-tables') ) {
3336
if ( $_ =~ m/\./ ) {
3337
$reject_qtbls{$_} = 1;
3342
} keys %{ $o->get('ignore-tables') };
3343
@reject_tbls= _make_filter('if', '$tbl', \%tbls);
3344
@reject_qtbls = _make_filter('if', '$qtbl', \%reject_qtbls);
3346
if ( @reject_qtbls && !$have_qtbl ) {
3348
' my $qtbl = ($db ? "$db." : "") . ($tbl ? $tbl : "");';
3352
if ( keys %permit_qtbls && !@permit_dbs ) {
3355
my ($db, undef) = split(/\./, $_);
3357
} keys %permit_qtbls;
3358
MKDEBUG && _d('Adding restriction "--databases',
3359
(join(',', keys %$dbs) . '"'));
3361
$o->set('databases', $dbs);
3362
return $self->make_filter($o);
3367
if ( $o->has('tables-regex') && (my $p = $o->get('tables-regex')) ) {
3368
push @tbls_regex, " return 0 unless \$tbl && (\$tbl =~ m/$p/o);";
3370
my @reject_tbls_regex;
3371
if ( $o->has('ignore-tables-regex')
3372
&& (my $p = $o->get('ignore-tables-regex')) ) {
3373
push @reject_tbls_regex,
3374
" return 0 if \$tbl && (\$tbl =~ m/$p/o);";
3380
if ( ($o->has('engines') && $o->get('engines'))
3381
|| ($o->has('ignore-engines') && $o->get('ignore-engines')) ) {
3383
' my $sql = "SHOW TABLE STATUS "',
3384
' . ($db ? "FROM `$db`" : "")',
3385
' . " LIKE \'$tbl\'";',
3386
' MKDEBUG && _d($sql);',
3388
' $engine = $dbh->selectrow_hashref($sql)->{engine};',
3390
' MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);',
3391
' MKDEBUG && _d($tbl, "uses engine", $engine);',
3392
' $engine = lc $engine if $engine;',
3394
= _make_filter('unless', '$engine', $o->get('engines'), 1);
3396
= _make_filter('if', '$engine', $o->get('ignore-engines'), 1)
3399
if ( @permit_tbls || @permit_qtbls || @reject_tbls || @tbls_regex
3400
|| @reject_tbls_regex || @permit_engs || @reject_engs ) {
3403
(@permit_tbls ? @permit_tbls : ()),
3404
(@reject_tbls ? @reject_tbls : ()),
3405
(@tbls_regex ? @tbls_regex : ()),
3406
(@reject_tbls_regex ? @reject_tbls_regex : ()),
3407
(@permit_qtbls ? @permit_qtbls : ()),
3408
(@reject_qtbls ? @reject_qtbls : ()),
3409
(@get_eng ? @get_eng : ()),
3410
(@permit_engs ? @permit_engs : ()),
3411
(@reject_engs ? @reject_engs : ()),
3417
' MKDEBUG && _d(\'Passes filters:\', $db, $tbl, $engine, $dbh);',
3420
my $code = join("\n", @lines);
3421
MKDEBUG && _d('filter sub:', $code);
3422
my $filter_sub= eval $code
3423
or die "Error compiling subroutine code:\n$code\n$EVAL_ERROR";
3429
my ( $self, $filter_sub ) = @_;
3430
$self->{filter} = $filter_sub;
3431
MKDEBUG && _d('Set filter sub');
3436
my ( $self, %args ) = @_;
3437
my @required_args = qw(dbh);
3438
foreach my $arg ( @required_args ) {
3439
die "I need a $arg argument" unless $args{$arg};
3441
my ($dbh) = @args{@required_args};
3443
my $filter = $self->{filter};
3446
my $sql = 'SHOW DATABASES';
3447
MKDEBUG && _d($sql);
3449
my $ok = $filter ? $filter->($dbh, $_, undef) : 1;
3450
$ok = 0 if $_ =~ m/information_schema|performance_schema|lost\+found/;
3452
} @{ $dbh->selectcol_arrayref($sql) };
3453
MKDEBUG && _d('Found', scalar @dbs, 'databases');
3456
MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
3457
my $iterator = sub {
3462
return ($iterator, scalar @dbs);
3470
my ( $self, %args ) = @_;
3471
my @required_args = qw(dbh db);
3472
foreach my $arg ( @required_args ) {
3473
die "I need a $arg argument" unless $args{$arg};
3475
my ($dbh, $db, $views) = @args{@required_args, 'views'};
3477
my $filter = $self->{filter};
3481
my $sql = 'SHOW /*!50002 FULL*/ TABLES FROM '
3482
. $self->{Quoter}->quote($db);
3483
MKDEBUG && _d($sql);
3488
my ($tbl, $type) = @$_;
3489
my $ok = $filter ? $filter->($dbh, $db, $tbl) : 1;
3491
$ok = 0 if ($type || '') eq 'VIEW';
3495
@{ $dbh->selectall_arrayref($sql) };
3496
MKDEBUG && _d('Found', scalar @tbls, 'tables in', $db);
3498
MKDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
3501
MKDEBUG && _d('No db given so no tables');
3504
my $iterator = sub {
3509
return ($iterator, scalar @tbls);
3517
my ( $cond, $var_name, $objs, $lc ) = @_;
3519
if ( scalar keys %$objs ) {
3520
my $test = join(' || ',
3521
map { "$var_name eq '" . ($lc ? lc $_ : $_) ."'" } keys %$objs);
3522
push @lines, " return 0 $cond $var_name && ($test);",
3528
my ($package, undef, $line) = caller 0;
3529
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3530
map { defined $_ ? $_ : 'undef' }
3532
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3537
# ###########################################################################
3538
# End SchemaIterator package
3539
# ###########################################################################
3541
# #############################################################################
3542
# This is a combination of modules and programs in one -- a runnable module.
3543
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
3544
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
3546
# Check at the end of this package for the call to main() which actually runs
3548
# #############################################################################
3549
package mk_duplicate_key_checker;
3551
use English qw(-no_match_vars);
3553
use List::Util qw(max);
3555
Transformers->import(qw(shorten));
3557
use constant MKDEBUG => $ENV{MKDEBUG} || 0;
3559
$OUTPUT_AUTOFLUSH = 1;
3562
my $hdr_width = $max_width - 2; # for '# '
3563
my $hdr_fmt = "# %-${hdr_width}s\n";
3566
@ARGV = @_; # set global ARGV for this package
3568
my %summary = ( 'Total Indexes' => 0 );
3571
my $q = new Quoter();
3572
my $tp = new TableParser(Quoter => $q);
3574
# #######################################################################
3575
# Get configuration information and parse command line options.
3576
# #######################################################################
3577
my $o = new OptionParser();
3581
my $dp = $o->DSNParser();
3582
$dp->prop('set-vars', $o->get('set-vars'));
3584
$o->usage_or_errors();
3586
# ########################################################################
3587
# If --pid, check it first since we'll die if it already exits.
3588
# ########################################################################
3590
if ( $o->get('pid') ) {
3591
# We're not daemoninzing, it just handles PID stuff. Keep $daemon
3592
# in the the scope of main() because when it's destroyed it automatically
3593
# removes the PID file.
3594
$daemon = new Daemon(o=>$o);
3595
$daemon->make_PID_file();
3598
# #######################################################################
3599
# Get ready to do the main work.
3600
# #######################################################################
3601
my $get_keys = $o->get('key-types') =~ m/k/ ? 1 : 0;
3602
my $get_fks = $o->get('key-types') =~ m/f/ ? 1 : 0;
3604
# Connect to the database
3605
if ( $o->got('ask-pass') ) {
3606
$o->set('password', OptionParser::prompt_noecho("Enter password: "));
3608
my $dsn_defaults = $dp->parse_options($o);
3609
my $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults)
3611
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn),
3612
{ AutoCommit => 1, });
3614
my $vp = new VersionParser();
3615
my $version = $vp->parse($dbh->selectrow_array('SELECT VERSION()'));
3617
my $ks = $o->get('summary') ? new KeySize(q=>$q) : undef;
3618
my $dk = new DuplicateKeyFinder();
3619
my $du = new MySQLDump();
3622
ignore_type => $o->get('all-structs'),
3623
ignore_order => $o->get('ignore-order'),
3624
clustered => $o->get('clustered'),
3627
# #######################################################################
3629
# #######################################################################
3631
my $si = new SchemaIterator(
3634
$si->set_filter($si->make_filter($o));
3635
my $next_db = $si->get_db_itr(dbh => $dbh);
3637
while ( my $database = $next_db->() ) {
3638
MKDEBUG && _d('Getting tables from', $database);
3639
my $next_tbl = $si->get_tbl_itr(
3645
while ( my $table = $next_tbl->() ) {
3646
MKDEBUG && _d('Got table', $table);
3648
# If get_create_table() fails, it will throw a warning and return
3649
# undef. So we can just move on to the next table.
3650
my $ddl = $du->get_create_table($dbh, $q, $database, $table);
3651
next TABLE unless $ddl;
3652
$ddl = $ddl->[1]; # retval is an arrayref: [table|view, SHOW CREATE]
3654
my $engine = $tp->get_engine($ddl) || next TABLE;
3662
my ($keys, $clustered_key)
3663
= $tp->get_keys($ddl, {version => $version }) if $get_keys;
3664
my $fks = $tp->get_fks($ddl, {database => $database}) if $get_fks;
3666
next TABLE unless %$keys || %$fks;
3668
if ( $o->got('verbose') ) {
3669
print_all_keys($keys, $tbl_info, \%seen_tbl) if $keys;
3670
print_all_keys($fks, $tbl_info, \%seen_tbl) if $fks;
3673
MKDEBUG && _d('Getting duplicate keys on', $database, $table);
3675
$dk->get_duplicate_keys(
3677
clustered_key => $clustered_key,
3678
tbl_info => $tbl_info,
3679
callback => \&print_duplicate_key,
3681
# get_duplicate_keys() ignores these args but passes them
3689
seen_tbl => \%seen_tbl,
3690
summary => \%summary,
3693
$dk->get_duplicate_fks(
3695
tbl_info => $tbl_info,
3696
callback => \&print_duplicate_key,
3698
# get_duplicate_fks() ignores these args but passes them
3706
seen_tbl => \%seen_tbl,
3707
summary => \%summary,
3710
if ( $EVAL_ERROR ) {
3711
warn "Error checking `$database`.`$table` for duplicate keys: "
3717
# Always count Total Keys so print_key_summary won't die
3718
# because %summary is empty.
3719
$summary{'Total Indexes'} += (scalar keys %$keys) + (scalar keys %$fks)
3723
print_key_summary(%summary) if $o->get('summary');
3728
# ##########################################################################
3730
# ##########################################################################
3732
sub print_all_keys {
3733
my ( $keys, $tbl_info, $seen_tbl ) = @_;
3734
return unless $keys;
3735
my $db = $tbl_info->{db};
3736
my $tbl = $tbl_info->{tbl};
3737
if ( !$seen_tbl->{"$db$tbl"}++ ) {
3738
printf $hdr_fmt, ('#' x $hdr_width);
3739
printf $hdr_fmt, "$db.$tbl";
3740
printf $hdr_fmt, ('#' x $hdr_width);
3742
foreach my $key ( values %$keys ) {
3743
print "\n# $key->{name} ($key->{colnames})";
3749
sub print_duplicate_key {
3750
my ( $dupe, %args ) = @_;
3751
return unless $dupe;
3752
foreach my $arg ( qw(tbl_info dbh is_fk o ks q tp seen_tbl) ) {
3753
die "I need a $arg argument" unless exists $args{$arg};
3755
MKDEBUG && _d('Printing duplicate key', $dupe->{key});
3756
my $db = $args{tbl_info}->{db};
3757
my $tbl = $args{tbl_info}->{tbl};
3758
my $dbh = $args{dbh};
3761
my $seen_tbl = $args{seen_tbl};
3764
my $summary = $args{summary};
3765
my $struct = $tp->parse($args{tbl_info}->{ddl});
3767
if ( !$seen_tbl->{"$db$tbl"}++ ) {
3768
printf $hdr_fmt, ('#' x $hdr_width);
3769
printf $hdr_fmt, "$db.$tbl";
3770
printf $hdr_fmt, ('#' x $hdr_width);
3774
$dupe->{reason} =~ s/\n/\n# /g;
3775
print "# $dupe->{reason}\n";
3777
print "# Key definitions:\n";
3778
print "# " . ($dupe->{ddl} || '') . "\n";
3779
print "# " . ($dupe->{duplicate_of_ddl} || '') . "\n";
3781
print "# Column types:\n";
3782
my %seen; # print each column only once
3783
foreach my $col ( @{$dupe->{cols}}, @{$dupe->{duplicate_of_cols}} ) {
3784
next if $seen{$col}++;
3785
MKDEBUG && _d('col', $col);
3786
print "#\t" . lc($struct->{defs}->{lc $col}) . "\n";
3789
if ( $o->get('sql') ) {
3790
if ( $dupe->{dupe_type} ne 'clustered' ) {
3791
print "# To remove this duplicate "
3792
. ($args{is_fk} ? 'foreign key' : 'index')
3794
. 'ALTER TABLE ' . $q->quote($db, $tbl)
3795
. ($args{is_fk} ? ' DROP FOREIGN KEY ' : ' DROP INDEX ')
3796
. "`$dupe->{key}`;\n";
3799
# Suggest shortening clustered dupes instead of
3800
# removing them (issue 295).
3801
print "# To shorten this duplicate clustered index, execute:\n"
3802
. 'ALTER TABLE '.$q->quote($db, $tbl)." DROP INDEX `$dupe->{key}`, "
3803
. "ADD INDEX `$dupe->{key}` ($dupe->{short_key});\n";
3808
if ( $o->get('summary') && $summary ) {
3809
$summary->{'Total Duplicate Indexes'} += 1;
3810
my ($size, $chosen_key) = $ks->get_key_size(
3811
name => $dupe->{key},
3812
cols => $dupe->{cols},
3813
tbl_name => $q->quote($db, $tbl),
3814
tbl_struct => $struct,
3817
if ( $args{is_fk} ) {
3818
# Foreign keys have no size because they're just constraints.
3819
print "# MySQL uses the $chosen_key index for this "
3820
. "foreign key constraint\n\n";
3825
# Create Size Duplicate Keys summary even if there's no valid keys.
3826
$summary->{'Size Duplicate Indexes'} += $size;
3829
if ( $chosen_key && $chosen_key ne $dupe->{key} ) {
3830
# This shouldn't happen. But in case it does, we should know.
3831
print "# MySQL chose the $chosen_key index despite FORCE INDEX\n\n";
3839
sub print_key_summary {
3840
my ( %summary ) = @_;
3841
printf $hdr_fmt, ('#' x $hdr_width);
3842
printf $hdr_fmt, 'Summary of indexes';
3843
printf $hdr_fmt, ('#' x $hdr_width);
3845
my $max_item = max(map { length($_) } keys %summary);
3846
my $line_fmt = "# %-${max_item}s %-s\n";
3847
foreach my $item ( sort keys %summary ) {
3848
printf $line_fmt, $item, $summary{$item};
3854
my ($package, undef, $line) = caller 0;
3855
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
3856
map { defined $_ ? $_ : 'undef' }
3858
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
3861
# ############################################################################
3863
# ############################################################################
3864
if ( !caller ) { exit main(@ARGV); }
3866
1; # Because this is a module as well as a script.
3868
# ############################################################################
3870
# ############################################################################
3876
mk-duplicate-key-checker - Find duplicate indexes and foreign keys on MySQL tables.
3880
Usage: mk-duplicate-key-checker [OPTION...] [DSN]
3882
mk-duplicate-key-checker examines MySQL tables for duplicate or redundant
3883
indexes and foreign keys. Connection options are read from MySQL option files.
3885
mk-duplicate-key-checker --host host1
3889
The following section is included to inform users about the potential risks,
3890
whether known or unknown, of using this tool. The two main categories of risks
3891
are those created by the nature of the tool (e.g. read-only tools vs. read-write
3892
tools) and those created by bugs.
3894
mk-duplicate-key-checker is a read-only tool that executes SHOW CREATE TABLE and
3895
related queries to inspect table structures, and thus is very low-risk.
3897
At the time of this release, there is an unconfirmed bug that causes the tool
3900
The authoritative source for updated information is always the online issue
3901
tracking system. Issues that affect this tool will be marked as such. You can
3902
see a list of such issues at the following URL:
3903
L<http://www.maatkit.org/bugs/mk-duplicate-key-checker>.
3905
See also L<"BUGS"> for more information on filing bugs and getting help.
3909
This program examines the output of SHOW CREATE TABLE on MySQL tables, and if
3910
it finds indexes that cover the same columns as another index in the same
3911
order, or cover an exact leftmost prefix of another index, it prints out
3912
the suspicious indexes. By default, indexes must be of the same type, so a
3913
BTREE index is not a duplicate of a FULLTEXT index, even if they have the same
3914
columns. You can override this.
3916
It also looks for duplicate foreign keys. A duplicate foreign key covers the
3917
same columns as another in the same table, and references the same parent
3922
This tool accepts additional command-line arguments. Refer to the
3923
L<"SYNOPSIS"> and usage information for details.
3929
Compare indexes with different structs (BTREE, HASH, etc).
3931
By default this is disabled, because a BTREE index that covers the same columns
3932
as a FULLTEXT index is not really a duplicate, for example.
3936
Prompt for a password when connecting to MySQL.
3940
short form: -A; type: string
3942
Default character set. If the value is utf8, sets Perl's binmode on
3943
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
3944
NAMES UTF8 after connecting to MySQL. Any other value sets binmode on STDOUT
3945
without the utf8 layer, and runs SET NAMES after connecting to MySQL.
3947
=item --[no]clustered
3951
PK columns appended to secondary key is duplicate.
3953
Detects when a suffix of a secondary key is a leftmost prefix of the primary
3954
key, and treats it as a duplicate key. Only detects this condition on storage
3955
engines whose primary keys are clustered (currently InnoDB and solidDB).
3957
Clustered storage engines append the primary key columns to the leaf nodes of
3958
all secondary keys anyway, so you might consider it redundant to have them
3959
appear in the internal nodes as well. Of course, you may also want them in the
3960
internal nodes, because just having them at the leaf nodes won't help for some
3961
queries. It does help for covering index queries, however.
3963
Here's an example of a key that is considered redundant with this option:
3968
The use of such indexes is rather subtle. For example, suppose you have the
3971
SELECT ... WHERE b=1 ORDER BY a;
3973
This query will do a filesort if we remove the index on C<b,a>. But if we
3974
shorten the index on C<b,a> to just C<b> and also remove the ORDER BY, the query
3975
should return the same results.
3977
The tool suggests shortening duplicate clustered keys by dropping the key
3978
and re-adding it without the primary key prefix. The shortened clustered
3979
key may still duplicate another key, but the tool cannot currently detect
3980
when this happens without being ran a second time to re-check the newly
3981
shortened clustered keys. Therefore, if you shorten any duplicate clustered
3982
keys, you should run the tool again.
3988
Read this comma-separated list of config files; if specified, this must be the
3989
first option on the command line.
3993
short form: -d; type: hash
3995
Check only this comma-separated list of databases.
3997
=item --defaults-file
3999
short form: -F; type: string
4001
Only read mysql options from the given file. You must give an absolute pathname.
4005
short form: -e; type: hash
4007
Check only tables whose storage engine is in this comma-separated list.
4015
short form: -h; type: string
4019
=item --ignore-databases
4023
Ignore this comma-separated list of databases.
4025
=item --ignore-engines
4029
Ignore this comma-separated list of storage engines.
4031
=item --ignore-order
4033
Ignore index order so KEY(a,b) duplicates KEY(b,a).
4035
=item --ignore-tables
4039
Ignore this comma-separated list of tables. Table names may be qualified with
4044
type: string; default: fk
4046
Check for duplicate f=foreign keys, k=keys or fk=both.
4050
short form: -p; type: string
4052
Password to use when connecting.
4058
Create the given PID file. The file contains the process ID of the script.
4059
The PID file is removed when the script exits. Before starting, the script
4060
checks if the PID file already exists. If it does not, then the script creates
4061
and writes its own PID to it. If it does, then the script checks the following:
4062
if the file contains a PID and a process is running with that PID, then
4063
the script dies; or, if there is no process running with that PID, then the
4064
script overwrites the file with its own PID and starts; else, if the file
4065
contains no PID, then the script dies.
4069
short form: -P; type: int
4071
Port number to use for connection.
4075
type: string; default: wait_timeout=10000
4077
Set these MySQL variables. Immediately after connecting to MySQL, this string
4078
will be appended to SET and executed.
4082
short form: -S; type: string
4084
Socket file to use for connection.
4090
Print DROP KEY statement for each duplicate key. By default an ALTER TABLE
4091
DROP KEY statement is printed below each duplicate key so that, if you want to
4092
remove the duplicate key, you can copy-paste the statement into MySQL.
4094
To disable printing these statements, specify --nosql.
4100
Print summary of indexes at end of output.
4104
short form: -t; type: hash
4106
Check only this comma-separated list of tables.
4108
Table names may be qualified with the database name.
4112
short form: -u; type: string
4114
User for login if not current user.
4120
Output all keys and/or foreign keys found, not just redundant ones.
4124
Show version and exit.
4130
These DSN options are used to create a DSN. Each option is given like
4131
C<option=value>. The options are case-sensitive, so P and p are not the
4132
same option. There cannot be whitespace before or after the C<=> and
4133
if the value contains whitespace it must be quoted. DSN options are
4134
comma-separated. See the L<maatkit> manpage for full details.
4140
dsn: charset; copy: yes
4142
Default character set.
4146
dsn: database; copy: yes
4152
dsn: mysql_read_default_file; copy: yes
4154
Only read default options from the given file
4158
dsn: host; copy: yes
4164
dsn: password; copy: yes
4166
Password to use when connecting.
4170
dsn: port; copy: yes
4172
Port number to use for connection.
4176
dsn: mysql_socket; copy: yes
4178
Socket file to use for connection.
4182
dsn: user; copy: yes
4184
User for login if not current user.
4190
You can download Maatkit from Google Code at
4191
L<http://code.google.com/p/maatkit/>, or you can get any of the tools
4192
easily with a command like the following:
4194
wget http://www.maatkit.org/get/toolname
4196
wget http://www.maatkit.org/trunk/toolname
4198
Where C<toolname> can be replaced with the name (or fragment of a name) of any
4199
of the Maatkit tools. Once downloaded, they're ready to run; no installation is
4200
needed. The first URL gets the latest released version of the tool, and the
4201
second gets the latest trunk code from Subversion.
4205
The environment variable C<MKDEBUG> enables verbose debugging output in all of
4210
=head1 SYSTEM REQUIREMENTS
4212
You need the following Perl modules: DBI and DBD::mysql.
4216
For a list of known bugs see L<http://www.maatkit.org/bugs/mk-duplicate-key-checker>.
4218
Please use Google Code Issues and Groups to report bugs or request support:
4219
L<http://code.google.com/p/maatkit/>. You can also join #maatkit on Freenode to
4222
Please include the complete command-line used to reproduce the problem you are
4223
seeing, the version of all MySQL servers involved, the complete output of the
4224
tool when run with L<"--version">, and if possible, debugging output produced by
4225
running with the C<MKDEBUG=1> environment variable.
4227
=head1 COPYRIGHT, LICENSE AND WARRANTY
4229
This program is copyright 2007-@CURRENTYEAR@ Baron Schwartz.
4230
Feedback and improvements are welcome.
4232
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
4233
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
4234
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
4236
This program is free software; you can redistribute it and/or modify it under
4237
the terms of the GNU General Public License as published by the Free Software
4238
Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
4239
systems, you can issue `man perlgpl' or `man perlartistic' to read these
4242
You should have received a copy of the GNU General Public License along with
4243
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
4244
Place, Suite 330, Boston, MA 02111-1307 USA.
4248
Baron Schwartz, Daniel Nichter
4250
=head1 ABOUT MAATKIT
4252
This tool is part of Maatkit, a toolkit for power users of MySQL. Maatkit
4253
was created by Baron Schwartz; Baron and Daniel Nichter are the primary
4254
code contributors. Both are employed by Percona. Financial support for
4255
Maatkit development is primarily provided by Percona and its clients.
4259
This manual page documents Ver @VERSION@ Distrib @DISTRIB@ $Revision: 7477 $.
added
removed
bin/pt-duplicate-key-checker
