~hingo/percona-toolkit/pqd-mongodb-24 : contents of bin/pt-find at revision 585

~hingo/percona-toolkit/pqd-mongodb-24 : (revision 585)

3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1	#!/usr/bin/env perl
	2
12 by Daniel Nichter Remove duplicate copyright notices. Add POD and copyright for Aspersa tools. Fix checking for "pt-pmp" instead of "pmp", etc.	3	# This program is part of Percona Toolkit: http://www.percona.com/software/
	4	# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
	5	# notices and disclaimers.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	6
	7	use strict;
	8	use warnings FATAL => 'all';
350.1.15 by Daniel Nichter Remove _d from Percona::Toolkit because I can't get it to export correctly. Put Percona::Toolkit in most tools.	9
	10	# This tool is "fat-packed": most of its dependent modules are embedded
	11	# in this file. Setting %INC to this file for each module makes Perl aware
	12	# of this so it will not try to load the module from @INC. See the tool's
	13	# documentation for a full list of dependencies.
	14	BEGIN {
	15	$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
	16	Percona::Toolkit
	17	DSNParser
	18	OptionParser
	19	Quoter
	20	TableParser
	21	Daemon
350.1.18 by fraserb at gmail Fix several test failures by doing s/HTTP::Micro/HTTPMicro/	22	HTTPMicro
522 by Daniel Nichter Rename Pingback.pm to VersionCheck.pm.	23	VersionCheck
350.1.15 by Daniel Nichter Remove _d from Percona::Toolkit because I can't get it to export correctly. Put Percona::Toolkit in most tools.	24	));
	25	}
	26
	27	# ###########################################################################
	28	# Percona::Toolkit package
	29	# This package is a copy without comments from the original. The original
	30	# with comments and its test file can be found in the Bazaar repository at,
	31	# lib/Percona/Toolkit.pm
	32	# t/lib/Percona/Toolkit.t
	33	# See https://launchpad.net/percona-toolkit for more information.
	34	# ###########################################################################
	35	{
	36	package Percona::Toolkit;
580.1.3 by Brian Fraser Build percona-toolkit-2.2.2	37	our $VERSION = '2.2.2';
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	38
350.1.15 by Daniel Nichter Remove _d from Percona::Toolkit because I can't get it to export correctly. Put Percona::Toolkit in most tools.	39	1;
	40	}
	41	# ###########################################################################
	42	# End Percona::Toolkit package
	43	# ###########################################################################
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	44
	45	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	46	# DSNParser package
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	47	# This package is a copy without comments from the original. The original
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	48	# with comments and its test file can be found in the Bazaar repository at,
	49	# lib/DSNParser.pm
	50	# t/lib/DSNParser.t
	51	# See https://launchpad.net/percona-toolkit for more information.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	52	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	53	{
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	54	package DSNParser;
	55
	56	use strict;
	57	use warnings FATAL => 'all';
	58	use English qw(-no_match_vars);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	59	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	60
	61	use Data::Dumper;
	62	$Data::Dumper::Indent = 0;
	63	$Data::Dumper::Quotekeys = 0;
	64
262.1.4 by Daniel Nichter Update DSNParser in all tools.	65	my $dsn_sep = qr/(?<!\\),/;
262.1.4 by Daniel Nichter Update DSNParser in all tools.	66
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	67	eval {
	68	require DBI;
	69	};
	70	my $have_dbi = $EVAL_ERROR ? 0 : 1;
	71
	72	sub new {
	73	my ( $class, %args ) = @_;
	74	foreach my $arg ( qw(opts) ) {
	75	die "I need a $arg argument" unless $args{$arg};
	76	}
	77	my $self = {
	78	opts => {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
	79	};
	80	foreach my $opt ( @{$args{opts}} ) {
	81	if ( !$opt->{key} \|\| !$opt->{desc} ) {
	82	die "Invalid DSN option: ", Dumper($opt);
	83	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	84	PTDEBUG && _d('DSN option:',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	85	join(', ',
	86	map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} \|\| '') : 'undef') }
	87	keys %$opt
	88	)
	89	);
	90	$self->{opts}->{$opt->{key}} = {
	91	dsn => $opt->{dsn},
	92	desc => $opt->{desc},
	93	copy => $opt->{copy} \|\| 0,
	94	};
	95	}
	96	return bless $self, $class;
	97	}
	98
	99	sub prop {
	100	my ( $self, $prop, $value ) = @_;
	101	if ( @_ > 2 ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	102	PTDEBUG && _d('Setting', $prop, 'property');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	103	$self->{$prop} = $value;
	104	}
	105	return $self->{$prop};
	106	}
	107
	108	sub parse {
	109	my ( $self, $dsn, $prev, $defaults ) = @_;
	110	if ( !$dsn ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	111	PTDEBUG && _d('No DSN to parse');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	112	return;
	113	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	114	PTDEBUG && _d('Parsing', $dsn);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	115	$prev \|\|= {};
	116	$defaults \|\|= {};
	117	my %given_props;
	118	my %final_props;
	119	my $opts = $self->{opts};
	120
262.1.4 by Daniel Nichter Update DSNParser in all tools.	121	foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
262.1.4 by Daniel Nichter Update DSNParser in all tools.	122	$dsn_part =~ s/\\,/,/g;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	123	if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
	124	$given_props{$prop_key} = $prop_val;
	125	}
	126	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	127	PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	128	$given_props{h} = $dsn_part;
	129	}
	130	}
	131
	132	foreach my $key ( keys %$opts ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	133	PTDEBUG && _d('Finding value for', $key);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	134	$final_props{$key} = $given_props{$key};
	135	if ( !defined $final_props{$key}
	136	&& defined $prev->{$key} && $opts->{$key}->{copy} )
	137	{
	138	$final_props{$key} = $prev->{$key};
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	139	PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	140	}
	141	if ( !defined $final_props{$key} ) {
	142	$final_props{$key} = $defaults->{$key};
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	143	PTDEBUG && _d('Copying value for', $key, 'from defaults');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	144	}
	145	}
	146
	147	foreach my $key ( keys %given_props ) {
	148	die "Unknown DSN option '$key' in '$dsn'. For more details, "
	149	. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
	150	. "for complete documentation."
	151	unless exists $opts->{$key};
	152	}
	153	if ( (my $required = $self->prop('required')) ) {
	154	foreach my $key ( keys %$required ) {
	155	die "Missing required DSN option '$key' in '$dsn'. For more details, "
	156	. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
	157	. "for complete documentation."
	158	unless $final_props{$key};
	159	}
	160	}
	161
	162	return \%final_props;
	163	}
	164
	165	sub parse_options {
	166	my ( $self, $o ) = @_;
	167	die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
	168	my $dsn_string
	169	= join(',',
	170	map { "$_=".$o->get($_); }
	171	grep { $o->has($_) && $o->get($_) }
	172	keys %{$self->{opts}}
	173	);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	174	PTDEBUG && _d('DSN string made from options:', $dsn_string);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	175	return $self->parse($dsn_string);
	176	}
	177
	178	sub as_string {
	179	my ( $self, $dsn, $props ) = @_;
	180	return $dsn unless ref $dsn;
262.1.4 by Daniel Nichter Update DSNParser in all tools.	181	my @keys = $props ? @$props : sort keys %$dsn;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	182	return join(',',
262.1.4 by Daniel Nichter Update DSNParser in all tools.	183	map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
	184	grep {
	185	exists $self->{opts}->{$_}
	186	&& exists $dsn->{$_}
	187	&& defined $dsn->{$_}
	188	} @keys);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	189	}
	190
	191	sub usage {
	192	my ( $self ) = @_;
	193	my $usage
	194	= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
	195	. " KEY COPY MEANING\n"
	196	. " === ==== =============================================\n";
	197	my %opts = %{$self->{opts}};
	198	foreach my $key ( sort keys %opts ) {
	199	$usage .= " $key "
	200	. ($opts{$key}->{copy} ? 'yes ' : 'no ')
	201	. ($opts{$key}->{desc} \|\| '[No description]')
	202	. "\n";
	203	}
	204	$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
	205	return $usage;
	206	}
	207
	208	sub get_cxn_params {
	209	my ( $self, $info ) = @_;
	210	my $dsn;
	211	my %opts = %{$self->{opts}};
	212	my $driver = $self->prop('dbidriver') \|\| '';
	213	if ( $driver eq 'Pg' ) {
	214	$dsn = 'DBI:Pg:dbname=' . ( $info->{D} \|\| '' ) . ';'
	215	. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
	216	grep { defined $info->{$_} }
	217	qw(h P));
	218	}
	219	else {
	220	$dsn = 'DBI:mysql:' . ( $info->{D} \|\| '' ) . ';'
	221	. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
	222	grep { defined $info->{$_} }
	223	qw(F h P S A))
440 by Brian Fraser Updated modules in all tools	224	. ';mysql_read_default_group=client'
440 by Brian Fraser Updated modules in all tools	225	. ($info->{L} ? ';mysql_local_infile=1' : '');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	226	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	227	PTDEBUG && _d($dsn);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	228	return ($dsn, $info->{u}, $info->{p});
	229	}
	230
	231	sub fill_in_dsn {
	232	my ( $self, $dbh, $dsn ) = @_;
	233	my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
	234	my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
	235	$user =~ s/@.*//;
	236	$dsn->{h} \|\|= $vars->{hostname}->{Value};
	237	$dsn->{S} \|\|= $vars->{'socket'}->{Value};
	238	$dsn->{P} \|\|= $vars->{port}->{Value};
	239	$dsn->{u} \|\|= $user;
	240	$dsn->{D} \|\|= $db;
	241	}
	242
	243	sub get_dbh {
	244	my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
	245	$opts \|\|= {};
	246	my $defaults = {
	247	AutoCommit => 0,
	248	RaiseError => 1,
	249	PrintError => 0,
	250	ShowErrorStatement => 1,
	251	mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
	252	};
	253	@{$defaults}{ keys %$opts } = values %$opts;
440 by Brian Fraser Updated modules in all tools	254	if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
	255	$defaults->{mysql_local_infile} = 1;
	256	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	257
	258	if ( $opts->{mysql_use_result} ) {
	259	$defaults->{mysql_use_result} = 1;
	260	}
	261
	262	if ( !$have_dbi ) {
	263	die "Cannot connect to MySQL because the Perl DBI module is not "
	264	. "installed or not found. Run 'perl -MDBI' to see the directories "
	265	. "that Perl searches for DBI. If DBI is not installed, try:\n"
	266	. " Debian/Ubuntu apt-get install libdbi-perl\n"
	267	. " RHEL/CentOS yum install perl-DBI\n"
344.1.2 by Brian Fraser Updated modules for all tools	268	. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	269
	270	}
	271
	272	my $dbh;
	273	my $tries = 2;
	274	while ( !$dbh && $tries-- ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	275	PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	276	join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	277
290.1.2 by fraserb at gmail Update all the modules	278	$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
290.1.2 by fraserb at gmail Update all the modules	279
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	280	if ( !$dbh && $EVAL_ERROR ) {
290.1.2 by fraserb at gmail Update all the modules	281	if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	282	die "Cannot connect to MySQL because the Perl DBD::mysql module is "
	283	. "not installed or not found. Run 'perl -MDBD::mysql' to see "
	284	. "the directories that Perl searches for DBD::mysql. If "
	285	. "DBD::mysql is not installed, try:\n"
	286	. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
	287	. " RHEL/CentOS yum install perl-DBD-MySQL\n"
	288	. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
	289	}
290.1.2 by fraserb at gmail Update all the modules	290	elsif ( $EVAL_ERROR =~ m/not a compiled character set\|character set utf8/ ) {
	291	PTDEBUG && _d('Going to try again without utf8 support');
	292	delete $defaults->{mysql_enable_utf8};
	293	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	294	if ( !$tries ) {
	295	die $EVAL_ERROR;
	296	}
	297	}
	298	}
	299
290.1.2 by fraserb at gmail Update all the modules	300	if ( $cxn_string =~ m/mysql/i ) {
	301	my $sql;
	302
	303	$sql = 'SELECT @@SQL_MODE';
	304	PTDEBUG && _d($dbh, $sql);
	305	my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
	306	if ( $EVAL_ERROR ) {
344.1.2 by Brian Fraser Updated modules for all tools	307	die "Error getting the current SQL_MODE: $EVAL_ERROR";
290.1.2 by fraserb at gmail Update all the modules	308	}
290.1.2 by fraserb at gmail Update all the modules	309
344.1.2 by Brian Fraser Updated modules for all tools	310	if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
344.1.2 by Brian Fraser Updated modules for all tools	311	$sql = qq{/!40101 SET NAMES "$charset"/};
531.2.2 by Daniel Nichter Update OptionParser and DSNParser in all tools.	312	PTDEBUG && _d($dbh, $sql);
290.1.2 by fraserb at gmail Update all the modules	313	eval { $dbh->do($sql) };
290.1.2 by fraserb at gmail Update all the modules	314	if ( $EVAL_ERROR ) {
344.1.2 by Brian Fraser Updated modules for all tools	315	die "Error setting NAMES to $charset: $EVAL_ERROR";
290.1.2 by fraserb at gmail Update all the modules	316	}
	317	PTDEBUG && _d('Enabling charset for STDOUT');
	318	if ( $charset eq 'utf8' ) {
	319	binmode(STDOUT, ':utf8')
	320	or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
	321	}
	322	else {
	323	binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
	324	}
	325	}
	326
531.2.2 by Daniel Nichter Update OptionParser and DSNParser in all tools.	327	if ( my $vars = $self->prop('set-vars') ) {
	328	$self->set_vars($dbh, $vars);
290.1.2 by fraserb at gmail Update all the modules	329	}
472.1.2 by Brian Fraser Update modules for all tools using DSNParser	330
	331	$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
	332	. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
	333	. ($sql_mode ? ",$sql_mode" : '')
	334	. '\'*/';
	335	PTDEBUG && _d($dbh, $sql);
	336	eval { $dbh->do($sql) };
	337	if ( $EVAL_ERROR ) {
	338	die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
	339	. ($sql_mode ? " and $sql_mode" : '')
	340	. ": $EVAL_ERROR";
	341	}
290.1.2 by fraserb at gmail Update all the modules	342	}
290.1.2 by fraserb at gmail Update all the modules	343
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	344	PTDEBUG && _d('DBH info: ',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	345	$dbh,
	346	Dumper($dbh->selectrow_hashref(
	347	'SELECT DATABASE(), CONNECTION_ID(), VERSION()/!50038 , @@hostname/')),
	348	'Connection info:', $dbh->{mysql_hostinfo},
	349	'Character set info:', Dumper($dbh->selectall_arrayref(
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	350	"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	351	'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
	352	'$DBI::VERSION:', $DBI::VERSION,
	353	);
	354
	355	return $dbh;
	356	}
	357
	358	sub get_hostname {
	359	my ( $self, $dbh ) = @_;
	360	if ( my ($host) = ($dbh->{mysql_hostinfo} \|\| '') =~ m/^(\w+) via/ ) {
	361	return $host;
	362	}
	363	my ( $hostname, $one ) = $dbh->selectrow_array(
	364	'SELECT /!50038 @@hostname, / 1');
	365	return $hostname;
	366	}
	367
	368	sub disconnect {
	369	my ( $self, $dbh ) = @_;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	370	PTDEBUG && $self->print_active_handles($dbh);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	371	$dbh->disconnect;
	372	}
	373
	374	sub print_active_handles {
	375	my ( $self, $thing, $level ) = @_;
	376	$level \|\|= 0;
	377	printf("# Active %sh: %s %s %s\n", ($thing->{Type} \|\| 'undef'), "\t" x $level,
	378	$thing, (($thing->{Type} \|\| '') eq 'st' ? $thing->{Statement} \|\| '' : ''))
	379	or die "Cannot print: $OS_ERROR";
	380	foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
	381	$self->print_active_handles( $handle, $level + 1 );
	382	}
	383	}
	384
	385	sub copy {
	386	my ( $self, $dsn_1, $dsn_2, %args ) = @_;
	387	die 'I need a dsn_1 argument' unless $dsn_1;
	388	die 'I need a dsn_2 argument' unless $dsn_2;
	389	my %new_dsn = map {
	390	my $key = $_;
	391	my $val;
	392	if ( $args{overwrite} ) {
	393	$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
	394	}
	395	else {
	396	$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
	397	}
	398	$key => $val;
	399	} keys %{$self->{opts}};
	400	return \%new_dsn;
	401	}
	402
531.2.2 by Daniel Nichter Update OptionParser and DSNParser in all tools.	403	sub set_vars {
	404	my ($self, $dbh, $vars) = @_;
	405
531.1.12 by Daniel Nichter Update DSNParser in all tools.	406	return unless $vars;
531.1.12 by Daniel Nichter Update DSNParser in all tools.	407
531.2.2 by Daniel Nichter Update OptionParser and DSNParser in all tools.	408	foreach my $var ( sort keys %$vars ) {
	409	my $val = $vars->{$var}->{val};
	410
	411	(my $quoted_var = $var) =~ s/_/\\_/;
	412	my ($var_exists, $current_val);
	413	eval {
	414	($var_exists, $current_val) = $dbh->selectrow_array(
	415	"SHOW VARIABLES LIKE '$quoted_var'");
	416	};
	417	my $e = $EVAL_ERROR;
	418	if ( $e ) {
	419	PTDEBUG && _d($e);
	420	}
	421
	422	if ( $vars->{$var}->{default} && !$var_exists ) {
	423	PTDEBUG && _d('Not setting default var', $var,
	424	'because it does not exist');
	425	next;
	426	}
	427
	428	if ( $current_val && $current_val eq $val ) {
	429	PTDEBUG && _d('Not setting var', $var, 'because its value',
	430	'is already', $val);
	431	next;
	432	}
	433
	434	my $sql = "SET SESSION $var=$val";
	435	PTDEBUG && _d($dbh, $sql);
	436	eval { $dbh->do($sql) };
	437	if ( my $set_error = $EVAL_ERROR ) {
	438	chomp($set_error);
	439	$set_error =~ s/ at \S+ line \d+//;
	440	my $msg = "Error setting $var: $set_error";
	441	if ( $current_val ) {
	442	$msg .= " The current value for $var is $current_val. "
	443	. "If the variable is read only (not dynamic), specify "
	444	. "--set-vars $var=$current_val to avoid this warning, "
	445	. "else manually set the variable and restart MySQL.";
	446	}
	447	warn $msg . "\n\n";
	448	}
	449	}
	450
	451	return;
	452	}
	453
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	454	sub _d {
	455	my ($package, undef, $line) = caller 0;
	456	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
	457	map { defined $_ ? $_ : 'undef' }
	458	@_;
	459	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
	460	}
	461
	462	1;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	463	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	464	# ###########################################################################
	465	# End DSNParser package
	466	# ###########################################################################
	467
	468	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	469	# OptionParser package
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	470	# This package is a copy without comments from the original. The original
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	471	# with comments and its test file can be found in the Bazaar repository at,
	472	# lib/OptionParser.pm
	473	# t/lib/OptionParser.t
	474	# See https://launchpad.net/percona-toolkit for more information.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	475	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	476	{
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	477	package OptionParser;
	478
	479	use strict;
	480	use warnings FATAL => 'all';
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	481	use English qw(-no_match_vars);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	482	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	483
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	484	use List::Util qw(max);
	485	use Getopt::Long;
531.2.2 by Daniel Nichter Update OptionParser and DSNParser in all tools.	486	use Data::Dumper;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	487
	488	my $POD_link_re = '[LC]<"?([^">]+)"?>';
	489
	490	sub new {
	491	my ( $class, %args ) = @_;
	492	my @required_args = qw();
	493	foreach my $arg ( @required_args ) {
	494	die "I need a $arg argument" unless $args{$arg};
	495	}
	496
	497	my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
	498	$program_name \|\|= $PROGRAM_NAME;
	499	my $home = $ENV{HOME} \|\| $ENV{HOMEPATH} \|\| $ENV{USERPROFILE} \|\| '.';
	500
	501	my %attributes = (
	502	'type' => 1,
	503	'short form' => 1,
	504	'group' => 1,
	505	'default' => 1,
	506	'cumulative' => 1,
	507	'negatable' => 1,
	508	);
	509
	510	my $self = {
	511	head1 => 'OPTIONS', # These args are used internally
	512	skip_rules => 0, # to instantiate another Option-
	513	item => '--(.*)', # Parser obj that parses the
	514	attributes => \%attributes, # DSN OPTIONS section. Tools
	515	parse_attributes => \&_parse_attribs, # don't tinker with these args.
	516
	517	%args,
	518
	519	strict => 1, # disabled by a special rule
	520	program_name => $program_name,
	521	opts => {},
	522	got_opts => 0,
	523	short_opts => {},
	524	defaults => {},
	525	groups => {},
	526	allowed_groups => {},
	527	errors => [],
	528	rules => [], # desc of rules for --help
	529	mutex => [], # rule: opts are mutually exclusive
	530	atleast1 => [], # rule: at least one opt is required
	531	disables => {}, # rule: opt disables other opts
	532	defaults_to => {}, # rule: opt defaults to value of other opt
	533	DSNParser => undef,
	534	default_files => [
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	535	"/etc/percona-toolkit/percona-toolkit.conf",
	536	"/etc/percona-toolkit/$program_name.conf",
	537	"$home/.percona-toolkit.conf",
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	538	"$home/.$program_name.conf",
	539	],
	540	types => {
	541	string => 's', # standard Getopt type
	542	int => 'i', # standard Getopt type
	543	float => 'f', # standard Getopt type
	544	Hash => 'H', # hash, formed from a comma-separated list
	545	hash => 'h', # hash as above, but only if a value is given
	546	Array => 'A', # array, similar to Hash
	547	array => 'a', # array, similar to hash
	548	DSN => 'd', # DSN
	549	size => 'z', # size with kMG suffix (powers of 2^10)
	550	time => 'm', # time, with an optional suffix of s/h/m/d
	551	},
	552	};
	553
	554	return bless $self, $class;
	555	}
	556
	557	sub get_specs {
	558	my ( $self, $file ) = @_;
	559	$file \|\|= $self->{file} \|\| __FILE__;
	560	my @specs = $self->_pod_to_specs($file);
	561	$self->_parse_specs(@specs);
	562
	563	open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
	564	my $contents = do { local $/ = undef; <$fh> };
	565	close $fh;
	566	if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	567	PTDEBUG && _d('Parsing DSN OPTIONS');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	568	my $dsn_attribs = {
	569	dsn => 1,
	570	copy => 1,
	571	};
	572	my $parse_dsn_attribs = sub {
	573	my ( $self, $option, $attribs ) = @_;
	574	map {
	575	my $val = $attribs->{$_};
	576	if ( $val ) {
	577	$val = $val eq 'yes' ? 1
	578	: $val eq 'no' ? 0
	579	: $val;
	580	$attribs->{$_} = $val;
	581	}
	582	} keys %$attribs;
	583	return {
	584	key => $option,
	585	%$attribs,
	586	};
	587	};
	588	my $dsn_o = new OptionParser(
	589	description => 'DSN OPTIONS',
	590	head1 => 'DSN OPTIONS',
	591	dsn => 0, # XXX don't infinitely recurse!
	592	item => '\* (.)', # key opts are a single character
	593	skip_rules => 1, # no rules before opts
	594	attributes => $dsn_attribs,
	595	parse_attributes => $parse_dsn_attribs,
	596	);
	597	my @dsn_opts = map {
	598	my $opts = {
	599	key => $_->{spec}->{key},
	600	dsn => $_->{spec}->{dsn},
	601	copy => $_->{spec}->{copy},
	602	desc => $_->{desc},
	603	};
	604	$opts;
	605	} $dsn_o->_pod_to_specs($file);
	606	$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
	607	}
	608
105 by Daniel Update OptionParser in all tools.	609	if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
76.1.2 by Daniel Nichter Update OptionParser in all tools.	610	$self->{version} = $1;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	611	PTDEBUG && _d($self->{version});
76.1.2 by Daniel Nichter Update OptionParser in all tools.	612	}
76.1.2 by Daniel Nichter Update OptionParser in all tools.	613
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	614	return;
	615	}
	616
	617	sub DSNParser {
	618	my ( $self ) = @_;
	619	return $self->{DSNParser};
	620	};
	621
	622	sub get_defaults_files {
	623	my ( $self ) = @_;
	624	return @{$self->{default_files}};
	625	}
	626
	627	sub _pod_to_specs {
	628	my ( $self, $file ) = @_;
	629	$file \|\|= $self->{file} \|\| __FILE__;
	630	open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
	631
	632	my @specs = ();
	633	my @rules = ();
	634	my $para;
	635
	636	local $INPUT_RECORD_SEPARATOR = '';
	637	while ( $para = <$fh> ) {
	638	next unless $para =~ m/^=head1 $self->{head1}/;
	639	last;
	640	}
	641
	642	while ( $para = <$fh> ) {
	643	last if $para =~ m/^=over/;
	644	next if $self->{skip_rules};
	645	chomp $para;
	646	$para =~ s/\s+/ /g;
	647	$para =~ s/$POD_link_re/$1/go;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	648	PTDEBUG && _d('Option rule:', $para);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	649	push @rules, $para;
	650	}
	651
	652	die "POD has no $self->{head1} section" unless $para;
	653
	654	do {
	655	if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
	656	chomp $para;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	657	PTDEBUG && _d($para);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	658	my %attribs;
	659
	660	$para = <$fh>; # read next paragraph, possibly attributes
	661
	662	if ( $para =~ m/: / ) { # attributes
	663	$para =~ s/\s+\Z//g;
	664	%attribs = map {
	665	my ( $attrib, $val) = split(/: /, $_);
	666	die "Unrecognized attribute for --$option: $attrib"
	667	unless $self->{attributes}->{$attrib};
	668	($attrib, $val);
	669	} split(/; /, $para);
	670	if ( $attribs{'short form'} ) {
	671	$attribs{'short form'} =~ s/-//;
	672	}
	673	$para = <$fh>; # read next paragraph, probably short help desc
	674	}
	675	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	676	PTDEBUG && _d('Option has no attributes');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	677	}
	678
	679	$para =~ s/\s+\Z//g;
	680	$para =~ s/\s+/ /g;
	681	$para =~ s/$POD_link_re/$1/go;
	682
	683	$para =~ s/\.(?:\n.\| [A-Z].\|\Z)//s;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	684	PTDEBUG && _d('Short help:', $para);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	685
	686	die "No description after option spec $option" if $para =~ m/^=item/;
	687
	688	if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
	689	$option = $base_option;
	690	$attribs{'negatable'} = 1;
	691	}
	692
	693	push @specs, {
	694	spec => $self->{parse_attributes}->($self, $option, \%attribs),
	695	desc => $para
	696	. (defined $attribs{default} ? " (default $attribs{default})" : ''),
	697	group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
	698	};
	699	}
	700	while ( $para = <$fh> ) {
	701	last unless $para;
	702	if ( $para =~ m/^=head1/ ) {
	703	$para = undef; # Can't 'last' out of a do {} block.
	704	last;
	705	}
	706	last if $para =~ m/^=item /;
	707	}
	708	} while ( $para );
	709
	710	die "No valid specs in $self->{head1}" unless @specs;
	711
	712	close $fh;
	713	return @specs, @rules;
	714	}
	715
	716	sub _parse_specs {
	717	my ( $self, @specs ) = @_;
	718	my %disables; # special rule that requires deferred checking
	719
	720	foreach my $opt ( @specs ) {
	721	if ( ref $opt ) { # It's an option spec, not a rule.
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	722	PTDEBUG && _d('Parsing opt spec:',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	723	map { ($_, '=>', $opt->{$_}) } keys %$opt);
	724
	725	my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\\|([^!+=]*))?/;
	726	if ( !$long ) {
	727	die "Cannot parse long option from spec $opt->{spec}";
	728	}
	729	$opt->{long} = $long;
	730
	731	die "Duplicate long option --$long" if exists $self->{opts}->{$long};
	732	$self->{opts}->{$long} = $opt;
	733
	734	if ( length $long == 1 ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	735	PTDEBUG && _d('Long opt', $long, 'looks like short opt');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	736	$self->{short_opts}->{$long} = $long;
	737	}
	738
	739	if ( $short ) {
	740	die "Duplicate short option -$short"
	741	if exists $self->{short_opts}->{$short};
	742	$self->{short_opts}->{$short} = $long;
	743	$opt->{short} = $short;
	744	}
	745	else {
	746	$opt->{short} = undef;
	747	}
	748
435.5.1 by fraserb at gmail Removed optional_value, made --version-check have default: off, updated the tools and documentation with the changes, and added the auto value to Pingback.pm	749	$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
	750	$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
	751	$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	752
	753	$opt->{group} \|\|= 'default';
	754	$self->{groups}->{ $opt->{group} }->{$long} = 1;
	755
	756	$opt->{value} = undef;
	757	$opt->{got} = 0;
	758
	759	my ( $type ) = $opt->{spec} =~ m/=(.)/;
	760	$opt->{type} = $type;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	761	PTDEBUG && _d($long, 'type:', $type);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	762
	763
	764	$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
	765
	766	if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
	767	$self->{defaults}->{$long} = defined $def ? $def : 1;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	768	PTDEBUG && _d($long, 'default:', $def);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	769	}
	770
	771	if ( $long eq 'config' ) {
	772	$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
	773	}
	774
	775	if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
	776	$disables{$long} = $dis;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	777	PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	778	}
	779
	780	$self->{opts}->{$long} = $opt;
	781	}
	782	else { # It's an option rule, not a spec.
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	783	PTDEBUG && _d('Parsing rule:', $opt);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	784	push @{$self->{rules}}, $opt;
	785	my @participants = $self->_get_participants($opt);
	786	my $rule_ok = 0;
	787
	788	if ( $opt =~ m/mutually exclusive\|one and only one/ ) {
	789	$rule_ok = 1;
	790	push @{$self->{mutex}}, \@participants;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	791	PTDEBUG && _d(@participants, 'are mutually exclusive');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	792	}
	793	if ( $opt =~ m/at least one\|one and only one/ ) {
	794	$rule_ok = 1;
	795	push @{$self->{atleast1}}, \@participants;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	796	PTDEBUG && _d(@participants, 'require at least one');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	797	}
	798	if ( $opt =~ m/default to/ ) {
	799	$rule_ok = 1;
	800	$self->{defaults_to}->{$participants[0]} = $participants[1];
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	801	PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	802	}
	803	if ( $opt =~ m/restricted to option groups/ ) {
	804	$rule_ok = 1;
	805	my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
	806	my @groups = split(',', $groups);
	807	%{$self->{allowed_groups}->{$participants[0]}} = map {
	808	s/\s+//;
	809	$_ => 1;
	810	} @groups;
	811	}
	812	if( $opt =~ m/accepts additional command-line arguments/ ) {
	813	$rule_ok = 1;
	814	$self->{strict} = 0;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	815	PTDEBUG && _d("Strict mode disabled by rule");
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	816	}
	817
	818	die "Unrecognized option rule: $opt" unless $rule_ok;
	819	}
	820	}
	821
	822	foreach my $long ( keys %disables ) {
	823	my @participants = $self->_get_participants($disables{$long});
	824	$self->{disables}->{$long} = \@participants;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	825	PTDEBUG && _d('Option', $long, 'disables', @participants);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	826	}
	827
	828	return;
	829	}
	830
	831	sub _get_participants {
	832	my ( $self, $str ) = @_;
	833	my @participants;
	834	foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
	835	die "Option --$long does not exist while processing rule $str"
	836	unless exists $self->{opts}->{$long};
	837	push @participants, $long;
	838	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	839	PTDEBUG && _d('Participants for', $str, ':', @participants);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	840	return @participants;
	841	}
	842
	843	sub opts {
	844	my ( $self ) = @_;
	845	my %opts = %{$self->{opts}};
	846	return %opts;
	847	}
	848
	849	sub short_opts {
	850	my ( $self ) = @_;
	851	my %short_opts = %{$self->{short_opts}};
	852	return %short_opts;
	853	}
	854
	855	sub set_defaults {
	856	my ( $self, %defaults ) = @_;
	857	$self->{defaults} = {};
	858	foreach my $long ( keys %defaults ) {
	859	die "Cannot set default for nonexistent option $long"
	860	unless exists $self->{opts}->{$long};
	861	$self->{defaults}->{$long} = $defaults{$long};
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	862	PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	863	}
	864	return;
	865	}
	866
	867	sub get_defaults {
	868	my ( $self ) = @_;
	869	return $self->{defaults};
	870	}
	871
	872	sub get_groups {
	873	my ( $self ) = @_;
	874	return $self->{groups};
	875	}
	876
	877	sub _set_option {
	878	my ( $self, $opt, $val ) = @_;
	879	my $long = exists $self->{opts}->{$opt} ? $opt
	880	: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
	881	: die "Getopt::Long gave a nonexistent option: $opt";
	882
	883	$opt = $self->{opts}->{$long};
	884	if ( $opt->{is_cumulative} ) {
	885	$opt->{value}++;
	886	}
435.5.1 by fraserb at gmail Removed optional_value, made --version-check have default: off, updated the tools and documentation with the changes, and added the auto value to Pingback.pm	887	else {
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	888	$opt->{value} = $val;
	889	}
	890	$opt->{got} = 1;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	891	PTDEBUG && _d('Got option', $long, '=', $val);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	892	}
	893
	894	sub get_opts {
	895	my ( $self ) = @_;
	896
	897	foreach my $long ( keys %{$self->{opts}} ) {
	898	$self->{opts}->{$long}->{got} = 0;
	899	$self->{opts}->{$long}->{value}
	900	= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
	901	: $self->{opts}->{$long}->{is_cumulative} ? 0
	902	: undef;
	903	}
	904	$self->{got_opts} = 0;
	905
	906	$self->{errors} = [];
	907
	908	if ( @ARGV && $ARGV[0] eq "--config" ) {
	909	shift @ARGV;
	910	$self->_set_option('config', shift @ARGV);
	911	}
	912	if ( $self->has('config') ) {
	913	my @extra_args;
	914	foreach my $filename ( split(',', $self->get('config')) ) {
	915	eval {
	916	push @extra_args, $self->_read_config_file($filename);
	917	};
	918	if ( $EVAL_ERROR ) {
	919	if ( $self->got('config') ) {
	920	die $EVAL_ERROR;
	921	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	922	elsif ( PTDEBUG ) {
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	923	_d($EVAL_ERROR);
	924	}
	925	}
	926	}
	927	unshift @ARGV, @extra_args;
	928	}
	929
	930	Getopt::Long::Configure('no_ignore_case', 'bundling');
	931	GetOptions(
	932	map { $_->{spec} => sub { $self->_set_option(@_); } }
	933	grep { $_->{long} ne 'config' } # --config is handled specially above.
	934	values %{$self->{opts}}
	935	) or $self->save_error('Error parsing options');
	936
	937	if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
76.1.2 by Daniel Nichter Update OptionParser in all tools.	938	if ( $self->{version} ) {
	939	print $self->{version}, "\n";
	940	}
	941	else {
	942	print "Error parsing version. See the VERSION section of the tool's documentation.\n";
	943	}
424.1.3 by Daniel Nichter Update OptionParser in all tools.	944	exit 1;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	945	}
	946
	947	if ( @ARGV && $self->{strict} ) {
	948	$self->save_error("Unrecognized command-line options @ARGV");
	949	}
	950
	951	foreach my $mutex ( @{$self->{mutex}} ) {
	952	my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
	953	if ( @set > 1 ) {
	954	my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
	955	@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
	956	. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
	957	. ' are mutually exclusive.';
	958	$self->save_error($err);
	959	}
	960	}
	961
	962	foreach my $required ( @{$self->{atleast1}} ) {
	963	my @set = grep { $self->{opts}->{$_}->{got} } @$required;
	964	if ( @set == 0 ) {
	965	my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
	966	@{$required}[ 0 .. scalar(@$required) - 2] )
	967	.' or --'.$self->{opts}->{$required->[-1]}->{long};
	968	$self->save_error("Specify at least one of $err");
	969	}
	970	}
	971
	972	$self->_check_opts( keys %{$self->{opts}} );
	973	$self->{got_opts} = 1;
	974	return;
	975	}
	976
	977	sub _check_opts {
	978	my ( $self, @long ) = @_;
	979	my $long_last = scalar @long;
	980	while ( @long ) {
	981	foreach my $i ( 0..$#long ) {
	982	my $long = $long[$i];
	983	next unless $long;
	984	my $opt = $self->{opts}->{$long};
	985	if ( $opt->{got} ) {
	986	if ( exists $self->{disables}->{$long} ) {
	987	my @disable_opts = @{$self->{disables}->{$long}};
	988	map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	989	PTDEBUG && _d('Unset options', @disable_opts,
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	990	'because', $long,'disables them');
	991	}
	992
	993	if ( exists $self->{allowed_groups}->{$long} ) {
	994
	995	my @restricted_groups = grep {
	996	!exists $self->{allowed_groups}->{$long}->{$_}
	997	} keys %{$self->{groups}};
	998
	999	my @restricted_opts;
	1000	foreach my $restricted_group ( @restricted_groups ) {
	1001	RESTRICTED_OPT:
	1002	foreach my $restricted_opt (
	1003	keys %{$self->{groups}->{$restricted_group}} )
	1004	{
	1005	next RESTRICTED_OPT if $restricted_opt eq $long;
	1006	push @restricted_opts, $restricted_opt
	1007	if $self->{opts}->{$restricted_opt}->{got};
	1008	}
	1009	}
	1010
	1011	if ( @restricted_opts ) {
	1012	my $err;
	1013	if ( @restricted_opts == 1 ) {
	1014	$err = "--$restricted_opts[0]";
	1015	}
	1016	else {
	1017	$err = join(', ',
	1018	map { "--$self->{opts}->{$_}->{long}" }
	1019	grep { $_ }
	1020	@restricted_opts[0..scalar(@restricted_opts) - 2]
	1021	)
	1022	. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
	1023	}
	1024	$self->save_error("--$long is not allowed with $err");
	1025	}
	1026	}
	1027
	1028	}
	1029	elsif ( $opt->{is_required} ) {
	1030	$self->save_error("Required option --$long must be specified");
	1031	}
	1032
	1033	$self->_validate_type($opt);
	1034	if ( $opt->{parsed} ) {
	1035	delete $long[$i];
	1036	}
	1037	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1038	PTDEBUG && _d('Temporarily failed to parse', $long);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1039	}
	1040	}
	1041
	1042	die "Failed to parse options, possibly due to circular dependencies"
	1043	if @long == $long_last;
	1044	$long_last = @long;
	1045	}
	1046
	1047	return;
	1048	}
	1049
	1050	sub _validate_type {
	1051	my ( $self, $opt ) = @_;
	1052	return unless $opt;
	1053
	1054	if ( !$opt->{type} ) {
	1055	$opt->{parsed} = 1;
	1056	return;
	1057	}
	1058
	1059	my $val = $opt->{value};
	1060
	1061	if ( $val && $opt->{type} eq 'm' ) { # type time
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1062	PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1063	my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
	1064	if ( !$suffix ) {
	1065	my ( $s ) = $opt->{desc} =~ m/$suffix (.)$/;
	1066	$suffix = $s \|\| 's';
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1067	PTDEBUG && _d('No suffix given; using', $suffix, 'for',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1068	$opt->{long}, '(value:', $val, ')');
	1069	}
	1070	if ( $suffix =~ m/[smhd]/ ) {
	1071	$val = $suffix eq 's' ? $num # Seconds
	1072	: $suffix eq 'm' ? $num * 60 # Minutes
	1073	: $suffix eq 'h' ? $num * 3600 # Hours
	1074	: $num * 86400; # Days
	1075	$opt->{value} = ($prefix \|\| '') . $val;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1076	PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1077	}
	1078	else {
	1079	$self->save_error("Invalid time suffix for --$opt->{long}");
	1080	}
	1081	}
	1082	elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1083	PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1084	my $prev = {};
	1085	my $from_key = $self->{defaults_to}->{ $opt->{long} };
	1086	if ( $from_key ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1087	PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1088	if ( $self->{opts}->{$from_key}->{parsed} ) {
	1089	$prev = $self->{opts}->{$from_key}->{value};
	1090	}
	1091	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1092	PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1093	$from_key, 'parsed');
	1094	return;
	1095	}
	1096	}
	1097	my $defaults = $self->{DSNParser}->parse_options($self);
	1098	$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
	1099	}
	1100	elsif ( $val && $opt->{type} eq 'z' ) { # type size
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1101	PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1102	$self->_parse_size($opt, $val);
	1103	}
	1104	elsif ( $opt->{type} eq 'H' \|\| (defined $val && $opt->{type} eq 'h') ) {
	1105	$opt->{value} = { map { $_ => 1 } split(/(?<!\\),\s*/, ($val \|\| '')) };
	1106	}
	1107	elsif ( $opt->{type} eq 'A' \|\| (defined $val && $opt->{type} eq 'a') ) {
	1108	$opt->{value} = [ split(/(?<!\\),\s*/, ($val \|\| '')) ];
	1109	}
	1110	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1111	PTDEBUG && _d('Nothing to validate for option',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1112	$opt->{long}, 'type', $opt->{type}, 'value', $val);
	1113	}
	1114
	1115	$opt->{parsed} = 1;
	1116	return;
	1117	}
	1118
	1119	sub get {
	1120	my ( $self, $opt ) = @_;
	1121	my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
	1122	die "Option $opt does not exist"
	1123	unless $long && exists $self->{opts}->{$long};
	1124	return $self->{opts}->{$long}->{value};
	1125	}
	1126
	1127	sub got {
	1128	my ( $self, $opt ) = @_;
	1129	my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
	1130	die "Option $opt does not exist"
	1131	unless $long && exists $self->{opts}->{$long};
	1132	return $self->{opts}->{$long}->{got};
	1133	}
	1134
	1135	sub has {
	1136	my ( $self, $opt ) = @_;
	1137	my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
	1138	return defined $long ? exists $self->{opts}->{$long} : 0;
	1139	}
	1140
	1141	sub set {
	1142	my ( $self, $opt, $val ) = @_;
	1143	my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
	1144	die "Option $opt does not exist"
	1145	unless $long && exists $self->{opts}->{$long};
	1146	$self->{opts}->{$long}->{value} = $val;
	1147	return;
	1148	}
	1149
	1150	sub save_error {
	1151	my ( $self, $error ) = @_;
	1152	push @{$self->{errors}}, $error;
	1153	return;
	1154	}
	1155
	1156	sub errors {
	1157	my ( $self ) = @_;
	1158	return $self->{errors};
	1159	}
	1160
	1161	sub usage {
	1162	my ( $self ) = @_;
	1163	warn "No usage string is set" unless $self->{usage}; # XXX
	1164	return "Usage: " . ($self->{usage} \|\| '') . "\n";
	1165	}
	1166
	1167	sub descr {
	1168	my ( $self ) = @_;
	1169	warn "No description string is set" unless $self->{description}; # XXX
	1170	my $descr = ($self->{description} \|\| $self->{program_name} \|\| '')
	1171	. " For more details, please use the --help option, "
	1172	. "or try 'perldoc $PROGRAM_NAME' "
	1173	. "for complete documentation.";
	1174	$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+\|$)/g)
	1175	unless $ENV{DONT_BREAK_LINES};
1176	$descr =~ s/ +$//mg;
1177	return $descr;
1178	}
1179
1180	sub usage_or_errors {
1181	my ( $self, $file, $return ) = @_;
1182	$file \|\|= $self->{file} \|\| __FILE__;
1183
1184	if ( !$self->{description} \|\| !$self->{usage} ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1185	PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1186	my %synop = $self->_parse_synopsis($file);
	1187	$self->{description} \|\|= $synop{description};
	1188	$self->{usage} \|\|= $synop{usage};
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1189	PTDEBUG && _d("Description:", $self->{description},
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1190	"\nUsage:", $self->{usage});
	1191	}
	1192
	1193	if ( $self->{opts}->{help}->{got} ) {
	1194	print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
	1195	exit 0 unless $return;
	1196	}
	1197	elsif ( scalar @{$self->{errors}} ) {
	1198	print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
424.1.3 by Daniel Nichter Update OptionParser in all tools.	1199	exit 1 unless $return;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1200	}
	1201
	1202	return;
	1203	}
	1204
	1205	sub print_errors {
	1206	my ( $self ) = @_;
	1207	my $usage = $self->usage() . "\n";
	1208	if ( (my @errors = @{$self->{errors}}) ) {
	1209	$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
	1210	. "\n";
	1211	}
	1212	return $usage . "\n" . $self->descr();
	1213	}
	1214
	1215	sub print_usage {
	1216	my ( $self ) = @_;
	1217	die "Run get_opts() before print_usage()" unless $self->{got_opts};
	1218	my @opts = values %{$self->{opts}};
	1219
	1220	my $maxl = max(
	1221	map {
	1222	length($_->{long}) # option long name
	1223	+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
	1224	+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
	1225	}
	1226	@opts);
	1227
	1228	my $maxs = max(0,
	1229	map {
	1230	length($_)
	1231	+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
	1232	+ ($self->{opts}->{$_}->{type} ? 2 : 0)
	1233	}
	1234	values %{$self->{short_opts}});
	1235
	1236	my $lcol = max($maxl, ($maxs + 3));
	1237	my $rcol = 80 - $lcol - 6;
	1238	my $rpad = ' ' x ( 80 - $rcol );
	1239
	1240	$maxs = max($lcol - 3, $maxs);
	1241
	1242	my $usage = $self->descr() . "\n" . $self->usage();
	1243
	1244	my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
	1245	push @groups, 'default';
	1246
	1247	foreach my $group ( reverse @groups ) {
	1248	$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
	1249	foreach my $opt (
	1250	sort { $a->{long} cmp $b->{long} }
	1251	grep { $_->{group} eq $group }
	1252	@opts )
	1253	{
	1254	my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
	1255	my $short = $opt->{short};
	1256	my $desc = $opt->{desc};
	1257
	1258	$long .= $opt->{type} ? "=$opt->{type}" : "";
	1259
	1260	if ( $opt->{type} && $opt->{type} eq 'm' ) {
	1261	my ($s) = $desc =~ m/$suffix (.)$/;
	1262	$s \|\|= 's';
	1263	$desc =~ s/\s+$suffix .$//;
1264	$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
1265	. "d=days; if no suffix, $s is used.";
1266	}
472.1.2 by Brian Fraser Update modules for all tools using DSNParser	1267	$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+\|(?<=\W)\|$)/g);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1268	$desc =~ s/ +$//mg;
	1269	if ( $short ) {
	1270	$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
	1271	}
	1272	else {
	1273	$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
	1274	}
	1275	}
	1276	}
	1277
	1278	$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
	1279
	1280	if ( (my @rules = @{$self->{rules}}) ) {
	1281	$usage .= "\nRules:\n\n";
	1282	$usage .= join("\n", map { " $_" } @rules) . "\n";
	1283	}
	1284	if ( $self->{DSNParser} ) {
	1285	$usage .= "\n" . $self->{DSNParser}->usage();
	1286	}
	1287	$usage .= "\nOptions and values after processing arguments:\n\n";
	1288	foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
	1289	my $val = $opt->{value};
	1290	my $type = $opt->{type} \|\| '';
	1291	my $bool = $opt->{spec} =~ m/^[\w-]+(?:\\|[\w-])?!?$/;
	1292	$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
	1293	: !defined $val ? '(No value)'
	1294	: $type eq 'd' ? $self->{DSNParser}->as_string($val)
	1295	: $type =~ m/H\|h/ ? join(',', sort keys %$val)
	1296	: $type =~ m/A\|a/ ? join(',', @$val)
	1297	: $val;
	1298	$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
	1299	}
	1300	return $usage;
	1301	}
	1302
	1303	sub prompt_noecho {
	1304	shift @_ if ref $_[0] eq __PACKAGE__;
	1305	my ( $prompt ) = @_;
	1306	local $OUTPUT_AUTOFLUSH = 1;
	1307	print $prompt
	1308	or die "Cannot print: $OS_ERROR";
	1309	my $response;
	1310	eval {
	1311	require Term::ReadKey;
	1312	Term::ReadKey::ReadMode('noecho');
	1313	chomp($response = <STDIN>);
	1314	Term::ReadKey::ReadMode('normal');
	1315	print "\n"
	1316	or die "Cannot print: $OS_ERROR";
	1317	};
	1318	if ( $EVAL_ERROR ) {
	1319	die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
	1320	}
	1321	return $response;
	1322	}
	1323
	1324	sub _read_config_file {
	1325	my ( $self, $filename ) = @_;
	1326	open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
	1327	my @args;
	1328	my $prefix = '--';
	1329	my $parse = 1;
	1330
	1331	LINE:
1332	while ( my $line = <$fh> ) {
1333	chomp $line;
1334	next LINE if $line =~ m/^\s*(?:\#\|\;\|$)/;
1335	$line =~ s/\s+#.*$//g;
1336	$line =~ s/^\s+\|\s+$//g;
1337	if ( $line eq '--' ) {
1338	$prefix = '';
1339	$parse = 0;
1340	next LINE;
1341	}
1342	if ( $parse
1343	&& (my($opt, $arg) = $line =~ m/^\s([^=\s]+?)(?:\s=\s(.?)\s*)?$/)
1344	) {
1345	push @args, grep { defined $_ } ("$prefix$opt", $arg);
1346	}
1347	elsif ( $line =~ m/./ ) {
1348	push @args, $line;
1349	}
1350	else {
1351	die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
1352	}
1353	}
1354	close $fh;
1355	return @args;
1356	}
1357
1358	sub read_para_after {
1359	my ( $self, $file, $regex ) = @_;
1360	open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
1361	local $INPUT_RECORD_SEPARATOR = '';
1362	my $para;
1363	while ( $para = <$fh> ) {
1364	next unless $para =~ m/^=pod$/m;
1365	last;
1366	}
1367	while ( $para = <$fh> ) {
1368	next unless $para =~ m/$regex/;
1369	last;
1370	}
1371	$para = <$fh>;
1372	chomp($para);
1373	close $fh or die "Can't close $file: $OS_ERROR";
1374	return $para;
1375	}
1376
1377	sub clone {
1378	my ( $self ) = @_;
1379
1380	my %clone = map {
1381	my $hashref = $self->{$_};
1382	my $val_copy = {};
1383	foreach my $key ( keys %$hashref ) {
1384	my $ref = ref $hashref->{$key};
1385	$val_copy->{$key} = !$ref ? $hashref->{$key}
1386	: $ref eq 'HASH' ? { %{$hashref->{$key}} }
1387	: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
1388	: $hashref->{$key};
1389	}
1390	$_ => $val_copy;
1391	} qw(opts short_opts defaults);
1392
1393	foreach my $scalar ( qw(got_opts) ) {
1394	$clone{$scalar} = $self->{$scalar};
1395	}
1396
1397	return bless \%clone;
1398	}
1399
1400	sub _parse_size {
1401	my ( $self, $opt, $val ) = @_;
1402
1403	if ( lc($val \|\| '') eq 'null' ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1404	PTDEBUG && _d('NULL size for', $opt->{long});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1405	$opt->{value} = 'null';
	1406	return;
	1407	}
	1408
	1409	my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
	1410	my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
	1411	if ( defined $num ) {
	1412	if ( $factor ) {
	1413	$num *= $factor_for{$factor};
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1414	PTDEBUG && _d('Setting option', $opt->{y},
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1415	'to num', $num, '* factor', $factor);
	1416	}
	1417	$opt->{value} = ($pre \|\| '') . $num;
	1418	}
	1419	else {
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1420	$self->save_error("Invalid size for --$opt->{long}: $val");
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1421	}
	1422	return;
	1423	}
	1424
	1425	sub _parse_attribs {
	1426	my ( $self, $option, $attribs ) = @_;
	1427	my $types = $self->{types};
	1428	return $option
	1429	. ($attribs->{'short form'} ? '\|' . $attribs->{'short form'} : '' )
	1430	. ($attribs->{'negatable'} ? '!' : '' )
	1431	. ($attribs->{'cumulative'} ? '+' : '' )
435.5.1 by fraserb at gmail Removed optional_value, made --version-check have default: off, updated the tools and documentation with the changes, and added the auto value to Pingback.pm	1432	. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1433	}
	1434
	1435	sub _parse_synopsis {
	1436	my ( $self, $file ) = @_;
	1437	$file \|\|= $self->{file} \|\| __FILE__;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1438	PTDEBUG && _d("Parsing SYNOPSIS in", $file);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1439
	1440	local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
	1441	open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
	1442	my $para;
	1443	1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
	1444	die "$file does not contain a SYNOPSIS section" unless $para;
	1445	my @synop;
	1446	for ( 1..2 ) { # 1 for the usage, 2 for the description
	1447	my $para = <$fh>;
	1448	push @synop, $para;
	1449	}
	1450	close $fh;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1451	PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1452	my ($usage, $desc) = @synop;
	1453	die "The SYNOPSIS section in $file is not formatted properly"
	1454	unless $usage && $desc;
	1455
	1456	$usage =~ s/^\s*Usage:\s+(.+)/$1/;
	1457	chomp $usage;
	1458
	1459	$desc =~ s/\n/ /g;
	1460	$desc =~ s/\s{2,}/ /g;
	1461	$desc =~ s/\. ([A-Z][a-z])/. $1/g;
	1462	$desc =~ s/\s+$//;
	1463
	1464	return (
	1465	description => $desc,
	1466	usage => $usage,
	1467	);
	1468	};
	1469
531.2.2 by Daniel Nichter Update OptionParser and DSNParser in all tools.	1470	sub set_vars {
	1471	my ($self, $file) = @_;
	1472	$file \|\|= $self->{file} \|\| __FILE__;
	1473
	1474	my %user_vars;
	1475	my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
	1476	if ( $user_vars ) {
	1477	foreach my $var_val ( @$user_vars ) {
	1478	my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
	1479	die "Invalid --set-vars value: $var_val\n" unless $var && $val;
	1480	$user_vars{$var} = {
	1481	val => $val,
	1482	default => 0,
	1483	};
	1484	}
	1485	}
	1486
	1487	my %default_vars;
	1488	my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
	1489	if ( $default_vars ) {
	1490	%default_vars = map {
	1491	my $var_val = $_;
	1492	my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
	1493	die "Invalid --set-vars value: $var_val\n" unless $var && $val;
	1494	$var => {
	1495	val => $val,
	1496	default => 1,
	1497	};
	1498	} split("\n", $default_vars);
	1499	}
	1500
	1501	my %vars = (
	1502	%default_vars, # first the tool's defaults
	1503	%user_vars, # then the user's which overwrite the defaults
	1504	);
	1505	PTDEBUG && _d('--set-vars:', Dumper(\%vars));
	1506	return \%vars;
	1507	}
	1508
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1509	sub _d {
	1510	my ($package, undef, $line) = caller 0;
	1511	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
	1512	map { defined $_ ? $_ : 'undef' }
	1513	@_;
	1514	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
	1515	}
	1516
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1517	if ( PTDEBUG ) {
76.1.2 by Daniel Nichter Update OptionParser in all tools.	1518	print '# ', $^X, ' ', $], "\n";
	1519	if ( my $uname = `uname -a` ) {
	1520	$uname =~ s/\s+/ /g;
	1521	print "# $uname\n";
	1522	}
	1523	print '# Arguments: ',
	1524	join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
	1525	}
	1526
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1527	1;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1528	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1529	# ###########################################################################
	1530	# End OptionParser package
	1531	# ###########################################################################
	1532
	1533	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1534	# Quoter package
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1535	# This package is a copy without comments from the original. The original
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1536	# with comments and its test file can be found in the Bazaar repository at,
	1537	# lib/Quoter.pm
	1538	# t/lib/Quoter.t
	1539	# See https://launchpad.net/percona-toolkit for more information.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1540	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1541	{
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1542	package Quoter;
	1543
	1544	use strict;
	1545	use warnings FATAL => 'all';
	1546	use English qw(-no_match_vars);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1547	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1548
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1549	use Data::Dumper;
	1550	$Data::Dumper::Indent = 1;
	1551	$Data::Dumper::Sortkeys = 1;
	1552	$Data::Dumper::Quotekeys = 0;
	1553
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1554	sub new {
	1555	my ( $class, %args ) = @_;
	1556	return bless {}, $class;
	1557	}
	1558
	1559	sub quote {
	1560	my ( $self, @vals ) = @_;
	1561	foreach my $val ( @vals ) {
	1562	$val =~ s/`/``/g;
	1563	}
	1564	return join('.', map { '`' . $_ . '`' } @vals);
	1565	}
	1566
	1567	sub quote_val {
362.6.2 by Brian Fraser Updated Quoter and ChangeHandler in all the modules	1568	my ( $self, $val, %args ) = @_;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1569
	1570	return 'NULL' unless defined $val; # undef = NULL
	1571	return "''" if $val eq ''; # blank string = ''
362.6.2 by Brian Fraser Updated Quoter and ChangeHandler in all the modules	1572	return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
	1573	&& !$args{is_char}; # unless is_char is true
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1574
	1575	$val =~ s/(['\\])/\\$1/g;
	1576	return "'$val'";
	1577	}
	1578
	1579	sub split_unquote {
	1580	my ( $self, $db_tbl, $default_db ) = @_;
	1581	my ( $db, $tbl ) = split(/[.]/, $db_tbl);
	1582	if ( !$tbl ) {
	1583	$tbl = $db;
	1584	$db = $default_db;
	1585	}
459.1.6 by Brian Fraser Pushed the lib/Percona/Toolkit.pm version, and added extra tests to t/lib/Percona/Toolkit.t	1586	for ($db, $tbl) {
	1587	next unless $_;
	1588	s/\A`//;
	1589	s/`\z//;
	1590	s/``/`/g;
	1591	}
	1592
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1593	return ($db, $tbl);
	1594	}
	1595
	1596	sub literal_like {
	1597	my ( $self, $like ) = @_;
	1598	return unless $like;
	1599	$like =~ s/([%_])/\\$1/g;
	1600	return "'$like'";
	1601	}
	1602
	1603	sub join_quote {
	1604	my ( $self, $default_db, $db_tbl ) = @_;
	1605	return unless $db_tbl;
	1606	my ($db, $tbl) = split(/[.]/, $db_tbl);
	1607	if ( !$tbl ) {
	1608	$tbl = $db;
	1609	$db = $default_db;
	1610	}
	1611	$db = "`$db`" if $db && $db !~ m/^`/;
	1612	$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
	1613	return $db ? "$db.$tbl" : $tbl;
	1614	}
	1615
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1616	sub serialize_list {
	1617	my ( $self, @args ) = @_;
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1618	PTDEBUG && _d('Serializing', Dumper(\@args));
503.16.11 by Daniel Nichter Update Quoter in all tools again.	1619	return unless @args;
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1620
	1621	my @parts;
	1622	foreach my $arg ( @args ) {
	1623	if ( defined $arg ) {
	1624	$arg =~ s/,/\\,/g; # escape commas
	1625	$arg =~ s/\\N/\\\\N/g; # escape literal \N
	1626	push @parts, $arg;
	1627	}
	1628	else {
	1629	push @parts, '\N';
	1630	}
	1631	}
	1632
	1633	my $string = join(',', @parts);
	1634	PTDEBUG && _d('Serialized: <', $string, '>');
	1635	return $string;
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1636	}
	1637
	1638	sub deserialize_list {
	1639	my ( $self, $string ) = @_;
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1640	PTDEBUG && _d('Deserializing <', $string, '>');
	1641	die "Cannot deserialize an undefined string" unless defined $string;
	1642
	1643	my @parts;
	1644	foreach my $arg ( split(/(?<!\\),/, $string) ) {
	1645	if ( $arg eq '\N' ) {
	1646	$arg = undef;
503.16.2 by Brian Fraser Update all modules that use Quoter	1647	}
503.16.2 by Brian Fraser Update all modules that use Quoter	1648	else {
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1649	$arg =~ s/\\,/,/g;
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1650	$arg =~ s/\\\\N/\\N/g;
503.16.2 by Brian Fraser Update all modules that use Quoter	1651	}
503.16.8 by Daniel Nichter Updqte Quoter in all tools.	1652	push @parts, $arg;
	1653	}
	1654
	1655	if ( !@parts ) {
	1656	my $n_empty_strings = $string =~ tr/,//;
	1657	$n_empty_strings++;
	1658	PTDEBUG && _d($n_empty_strings, 'empty strings');
	1659	map { push @parts, '' } 1..$n_empty_strings;
	1660	}
	1661	elsif ( $string =~ m/(?<!\\),$/ ) {
	1662	PTDEBUG && _d('Last value is an empty string');
	1663	push @parts, '';
	1664	}
	1665
	1666	PTDEBUG && _d('Deserialized', Dumper(\@parts));
	1667	return @parts;
	1668	}
	1669
	1670	sub _d {
	1671	my ($package, undef, $line) = caller 0;
	1672	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
	1673	map { defined $_ ? $_ : 'undef' }
	1674	@_;
	1675	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1676	}
	1677
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1678	1;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1679	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1680	# ###########################################################################
	1681	# End Quoter package
	1682	# ###########################################################################
	1683
	1684	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1685	# TableParser package
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1686	# This package is a copy without comments from the original. The original
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1687	# with comments and its test file can be found in the Bazaar repository at,
	1688	# lib/TableParser.pm
	1689	# t/lib/TableParser.t
	1690	# See https://launchpad.net/percona-toolkit for more information.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1691	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1692	{
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1693	package TableParser;
	1694
	1695	use strict;
	1696	use warnings FATAL => 'all';
	1697	use English qw(-no_match_vars);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1698	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	1699
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1700	use Data::Dumper;
	1701	$Data::Dumper::Indent = 1;
	1702	$Data::Dumper::Sortkeys = 1;
	1703	$Data::Dumper::Quotekeys = 0;
	1704
459.1.6 by Brian Fraser Pushed the lib/Percona/Toolkit.pm version, and added extra tests to t/lib/Percona/Toolkit.t	1705	local $EVAL_ERROR;
	1706	eval {
	1707	require Quoter;
	1708	};
	1709
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1710	sub new {
	1711	my ( $class, %args ) = @_;
	1712	my $self = { %args };
459.1.6 by Brian Fraser Pushed the lib/Percona/Toolkit.pm version, and added extra tests to t/lib/Percona/Toolkit.t	1713	$self->{Quoter} \|\|= Quoter->new();
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1714	return bless $self, $class;
	1715	}
	1716
459.1.6 by Brian Fraser Pushed the lib/Percona/Toolkit.pm version, and added extra tests to t/lib/Percona/Toolkit.t	1717	sub Quoter { shift->{Quoter} }
	1718
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1719	sub get_create_table {
	1720	my ( $self, $dbh, $db, $tbl ) = @_;
	1721	die "I need a dbh parameter" unless $dbh;
	1722	die "I need a db parameter" unless $db;
	1723	die "I need a tbl parameter" unless $tbl;
	1724	my $q = $self->{Quoter};
	1725
	1726	my $new_sql_mode
410.1.3 by Daniel Nichter Update TableParser in all tools.	1727	= q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, }
	1728	. q{@@SQL_MODE := '', }
	1729	. q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, }
	1730	. q{@@SQL_QUOTE_SHOW_CREATE := 1 */};
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1731
410.1.3 by Daniel Nichter Update TableParser in all tools.	1732	my $old_sql_mode
	1733	= q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, }
	1734	. q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */};
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1735
	1736	PTDEBUG && _d($new_sql_mode);
	1737	eval { $dbh->do($new_sql_mode); };
	1738	PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
	1739
	1740	my $use_sql = 'USE ' . $q->quote($db);
	1741	PTDEBUG && _d($dbh, $use_sql);
	1742	$dbh->do($use_sql);
	1743
	1744	my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
	1745	PTDEBUG && _d($show_sql);
	1746	my $href;
	1747	eval { $href = $dbh->selectrow_hashref($show_sql); };
435.6.1 by Brian Fraser Fix for 1047335: SchemaIterator fails when it encounters a crashed table	1748	if ( my $e = $EVAL_ERROR ) {
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1749	PTDEBUG && _d($old_sql_mode);
	1750	$dbh->do($old_sql_mode);
	1751
435.6.1 by Brian Fraser Fix for 1047335: SchemaIterator fails when it encounters a crashed table	1752	die $e;
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1753	}
	1754
	1755	PTDEBUG && _d($old_sql_mode);
	1756	$dbh->do($old_sql_mode);
	1757
	1758	my ($key) = grep { m/create (?:table\|view)/i } keys %$href;
	1759	if ( !$key ) {
	1760	die "Error: no 'Create Table' or 'Create View' in result set from "
	1761	. "$show_sql: " . Dumper($href);
	1762	}
	1763
	1764	return $href->{$key};
	1765	}
	1766
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1767	sub parse {
	1768	my ( $self, $ddl, $opts ) = @_;
	1769	return unless $ddl;
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1770
	1771	if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
	1772	$ddl = $self->ansi_to_legacy($ddl);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1773	}
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1774	elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
	1775	die "TableParser doesn't handle CREATE TABLE without quoting.";
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1776	}
	1777
	1778	my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
	1779	(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
	1780
	1781	$ddl =~ s/(`[^`]+`)/\L$1/g;
	1782
	1783	my $engine = $self->get_engine($ddl);
	1784
	1785	my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
	1786	my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1787	PTDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1788
	1789	my %def_for;
	1790	@def_for{@cols} = @defs;
	1791
	1792	my (@nums, @null);
	1793	my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
	1794	foreach my $col ( @cols ) {
	1795	my $def = $def_for{$col};
	1796	my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
	1797	die "Can't determine column type for $def" unless $type;
	1798	$type_for{$col} = $type;
	1799	if ( $type =~ m/(?:(?:tiny\|big\|medium\|small)?int\|float\|double\|decimal\|year)/ ) {
	1800	push @nums, $col;
	1801	$is_numeric{$col} = 1;
	1802	}
	1803	if ( $def !~ m/NOT NULL/ ) {
	1804	push @null, $col;
	1805	$is_nullable{$col} = 1;
	1806	}
	1807	$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
	1808	}
	1809
	1810	my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
	1811
	1812	my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
	1813
	1814	return {
	1815	name => $name,
	1816	cols => \@cols,
	1817	col_posn => { map { $cols[$_] => $_ } 0..$#cols },
	1818	is_col => { map { $_ => 1 } @cols },
	1819	null_cols => \@null,
	1820	is_nullable => \%is_nullable,
	1821	is_autoinc => \%is_autoinc,
	1822	clustered_key => $clustered_key,
	1823	keys => $keys,
	1824	defs => \%def_for,
	1825	numeric_cols => \@nums,
	1826	is_numeric => \%is_numeric,
	1827	engine => $engine,
	1828	type_for => \%type_for,
	1829	charset => $charset,
	1830	};
	1831	}
	1832
	1833	sub sort_indexes {
	1834	my ( $self, $tbl ) = @_;
	1835
	1836	my @indexes
	1837	= sort {
	1838	(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
	1839	\|\| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
	1840	\|\| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
	1841	\|\| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
	1842	}
	1843	grep {
	1844	$tbl->{keys}->{$_}->{type} eq 'BTREE'
	1845	}
	1846	sort keys %{$tbl->{keys}};
	1847
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1848	PTDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1849	return @indexes;
	1850	}
	1851
	1852	sub find_best_index {
	1853	my ( $self, $tbl, $index ) = @_;
	1854	my $best;
	1855	if ( $index ) {
	1856	($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
	1857	}
	1858	if ( !$best ) {
	1859	if ( $index ) {
	1860	die "Index '$index' does not exist in table";
	1861	}
	1862	else {
	1863	($best) = $self->sort_indexes($tbl);
	1864	}
	1865	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1866	PTDEBUG && _d('Best index found is', $best);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1867	return $best;
	1868	}
	1869
	1870	sub find_possible_keys {
	1871	my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
	1872	return () unless $where;
	1873	my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
	1874	. ' WHERE ' . $where;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1875	PTDEBUG && _d($sql);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1876	my $expl = $dbh->selectrow_hashref($sql);
	1877	$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
	1878	if ( $expl->{possible_keys} ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1879	PTDEBUG && _d('possible_keys =', $expl->{possible_keys});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1880	my @candidates = split(',', $expl->{possible_keys});
	1881	my %possible = map { $_ => 1 } @candidates;
	1882	if ( $expl->{key} ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1883	PTDEBUG && _d('MySQL chose', $expl->{key});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1884	unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1885	PTDEBUG && _d('Before deduping:', join(', ', @candidates));
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1886	my %seen;
	1887	@candidates = grep { !$seen{$_}++ } @candidates;
	1888	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1889	PTDEBUG && _d('Final list:', join(', ', @candidates));
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1890	return @candidates;
	1891	}
	1892	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1893	PTDEBUG && _d('No keys in possible_keys');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1894	return ();
	1895	}
	1896	}
	1897
	1898	sub check_table {
	1899	my ( $self, %args ) = @_;
	1900	my @required_args = qw(dbh db tbl);
	1901	foreach my $arg ( @required_args ) {
	1902	die "I need a $arg argument" unless $args{$arg};
	1903	}
	1904	my ($dbh, $db, $tbl) = @args{@required_args};
520 by Brian Fraser Merged use-lmo.	1905	my $q = $self->{Quoter} \|\| 'Quoter';
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1906	my $db_tbl = $q->quote($db, $tbl);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1907	PTDEBUG && _d('Checking', $db_tbl);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1908
	1909	my $sql = "SHOW TABLES FROM " . $q->quote($db)
	1910	. ' LIKE ' . $q->literal_like($tbl);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1911	PTDEBUG && _d($sql);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1912	my $row;
	1913	eval {
	1914	$row = $dbh->selectrow_arrayref($sql);
	1915	};
	1916	if ( $EVAL_ERROR ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1917	PTDEBUG && _d($EVAL_ERROR);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1918	return 0;
	1919	}
	1920	if ( !$row->[0] \|\| $row->[0] ne $tbl ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1921	PTDEBUG && _d('Table does not exist');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1922	return 0;
	1923	}
	1924
416.1.3 by Daniel Nichter Remove TableParser::check_table() privs check (re bug 1036747).	1925	PTDEBUG && _d('Table', $db, $tbl, 'exists');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1926	return 1;
416.1.3 by Daniel Nichter Remove TableParser::check_table() privs check (re bug 1036747).	1927
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1928	}
	1929
	1930	sub get_engine {
	1931	my ( $self, $ddl, $opts ) = @_;
	1932	my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE\|TYPE)=(\w+)/;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1933	PTDEBUG && _d('Storage engine:', $engine);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1934	return $engine \|\| undef;
	1935	}
	1936
	1937	sub get_keys {
	1938	my ( $self, $ddl, $opts, $is_nullable ) = @_;
	1939	my $engine = $self->get_engine($ddl);
	1940	my $keys = {};
	1941	my $clustered_key = undef;
	1942
	1943	KEY:
	1944	foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
	1945
	1946	next KEY if $key =~ m/FOREIGN/;
	1947
	1948	my $key_ddl = $key;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1949	PTDEBUG && _d('Parsed key:', $key_ddl);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1950
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1951	if ( !$engine \|\| $engine !~ m/MEMORY\|HEAP/ ) {
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1952	$key =~ s/USING HASH/USING BTREE/;
	1953	}
	1954
	1955	my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? $(.+)$/;
	1956	my ( $special ) = $key =~ m/(FULLTEXT\|SPATIAL)/;
	1957	$type = $type \|\| $special \|\| 'BTREE';
	1958	my ($name) = $key =~ m/(PRIMARY\|`[^`]*`)/;
	1959	my $unique = $key =~ m/PRIMARY\|UNIQUE/ ? 1 : 0;
	1960	my @cols;
	1961	my @col_prefixes;
	1962	foreach my $col_def ( $cols =~ m/`[^`]+`(?:$\d+$)?/g ) {
	1963	my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:$(\d+)$)?/;
	1964	push @cols, $name;
	1965	push @col_prefixes, $prefix;
	1966	}
	1967	$name =~ s/`//g;
	1968
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1969	PTDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1970
	1971	$keys->{$name} = {
	1972	name => $name,
	1973	type => $type,
	1974	colnames => $cols,
	1975	cols => \@cols,
	1976	col_prefixes => \@col_prefixes,
	1977	is_unique => $unique,
	1978	is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
	1979	is_col => { map { $_ => 1 } @cols },
	1980	ddl => $key_ddl,
	1981	};
	1982
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	1983	if ( ($engine \|\| '') =~ m/InnoDB/i && !$clustered_key ) {
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1984	my $this_key = $keys->{$name};
	1985	if ( $this_key->{name} eq 'PRIMARY' ) {
	1986	$clustered_key = 'PRIMARY';
	1987	}
	1988	elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
	1989	$clustered_key = $this_key->{name};
	1990	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	1991	PTDEBUG && $clustered_key && _d('This key is the clustered key');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	1992	}
	1993	}
	1994
	1995	return $keys, $clustered_key;
	1996	}
	1997
	1998	sub get_fks {
	1999	my ( $self, $ddl, $opts ) = @_;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2000	my $q = $self->{Quoter};
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2001	my $fks = {};
	2002
	2003	foreach my $fk (
	2004	$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
	2005	{
	2006	my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
	2007	my ( $cols ) = $fk =~ m/FOREIGN KEY $([^$]+)\)/;
	2008	my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) $([^$]+)\)/;
	2009
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2010	my ($db, $tbl) = $q->split_unquote($parent, $opts->{database});
	2011	my %parent_tbl = (tbl => $tbl);
	2012	$parent_tbl{db} = $db if $db;
	2013
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2014	if ( $parent !~ m/\./ && $opts->{database} ) {
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2015	$parent = $q->quote($opts->{database}) . ".$parent";
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2016	}
	2017
	2018	$fks->{$name} = {
	2019	name => $name,
	2020	colnames => $cols,
	2021	cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2022	parent_tbl => \%parent_tbl,
	2023	parent_tblname => $parent,
	2024	parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2025	parent_colnames=> $parent_cols,
	2026	ddl => $fk,
	2027	};
	2028	}
	2029
	2030	return $fks;
	2031	}
	2032
	2033	sub remove_auto_increment {
	2034	my ( $self, $ddl ) = @_;
	2035	$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
	2036	return $ddl;
	2037	}
	2038
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	2039	sub get_table_status {
	2040	my ( $self, $dbh, $db, $like ) = @_;
	2041	my $q = $self->{Quoter};
	2042	my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
	2043	my @params;
	2044	if ( $like ) {
	2045	$sql .= ' LIKE ?';
	2046	push @params, $like;
	2047	}
	2048	PTDEBUG && _d($sql, @params);
	2049	my $sth = $dbh->prepare($sql);
	2050	eval { $sth->execute(@params); };
	2051	if ($EVAL_ERROR) {
	2052	PTDEBUG && _d($EVAL_ERROR);
	2053	return;
	2054	}
	2055	my @tables = @{$sth->fetchall_arrayref({})};
	2056	@tables = map {
	2057	my %tbl; # Make a copy with lowercased keys
	2058	@tbl{ map { lc $_ } keys %$_ } = values %$_;
	2059	$tbl{engine} \|\|= $tbl{type} \|\| $tbl{comment};
	2060	delete $tbl{type};
	2061	\%tbl;
	2062	} @tables;
	2063	return @tables;
	2064	}
	2065
	2066	my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx;
	2067	sub ansi_to_legacy {
	2068	my ($self, $ddl) = @_;
	2069	$ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge;
	2070	return $ddl;
	2071	}
	2072
	2073	sub ansi_quote_replace {
	2074	my ($val) = @_;
	2075	$val =~ s/^"\|"$//g;
	2076	$val =~ s/`/``/g;
	2077	$val =~ s/""/"/g;
	2078	return "`$val`";
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2079	}
	2080
	2081	sub _d {
	2082	my ($package, undef, $line) = caller 0;
	2083	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
	2084	map { defined $_ ? $_ : 'undef' }
	2085	@_;
	2086	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
	2087	}
	2088
	2089	1;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2090	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2091	# ###########################################################################
	2092	# End TableParser package
	2093	# ###########################################################################
	2094
	2095	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2096	# Daemon package
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2097	# This package is a copy without comments from the original. The original
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2098	# with comments and its test file can be found in the Bazaar repository at,
	2099	# lib/Daemon.pm
	2100	# t/lib/Daemon.t
	2101	# See https://launchpad.net/percona-toolkit for more information.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2102	# ###########################################################################
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2103	{
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2104	package Daemon;
	2105
	2106	use strict;
	2107	use warnings FATAL => 'all';
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2108	use English qw(-no_match_vars);
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2109	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2110
	2111	use POSIX qw(setsid);
	2112
	2113	sub new {
	2114	my ( $class, %args ) = @_;
	2115	foreach my $arg ( qw(o) ) {
	2116	die "I need a $arg argument" unless $args{$arg};
	2117	}
	2118	my $o = $args{o};
	2119	my $self = {
	2120	o => $o,
	2121	log_file => $o->has('log') ? $o->get('log') : undef,
	2122	PID_file => $o->has('pid') ? $o->get('pid') : undef,
	2123	};
	2124
	2125	check_PID_file(undef, $self->{PID_file});
	2126
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2127	PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2128	return bless $self, $class;
	2129	}
	2130
	2131	sub daemonize {
	2132	my ( $self ) = @_;
	2133
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2134	PTDEBUG && _d('About to fork and daemonize');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2135	defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
	2136	if ( $pid ) {
212 by Daniel Nichter Update Daemon in all tools (bug 944420).	2137	PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2138	exit;
	2139	}
	2140
212 by Daniel Nichter Update Daemon in all tools (bug 944420).	2141	PTDEBUG && _d('Daemonizing child PID', $PID);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2142	$self->{PID_owner} = $PID;
	2143	$self->{child} = 1;
	2144
	2145	POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
	2146	chdir '/' or die "Cannot chdir to /: $OS_ERROR";
	2147
	2148	$self->_make_PID_file();
	2149
	2150	$OUTPUT_AUTOFLUSH = 1;
	2151
212 by Daniel Nichter Update Daemon in all tools (bug 944420).	2152	PTDEBUG && _d('Redirecting STDIN to /dev/null');
	2153	close STDIN;
	2154	open STDIN, '/dev/null'
	2155	or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2156
	2157	if ( $self->{log_file} ) {
212 by Daniel Nichter Update Daemon in all tools (bug 944420).	2158	PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2159	close STDOUT;
	2160	open STDOUT, '>>', $self->{log_file}
	2161	or die "Cannot open log file $self->{log_file}: $OS_ERROR";
	2162
	2163	close STDERR;
	2164	open STDERR, ">&STDOUT"
	2165	or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
	2166	}
	2167	else {
	2168	if ( -t STDOUT ) {
212 by Daniel Nichter Update Daemon in all tools (bug 944420).	2169	PTDEBUG && _d('No log file and STDOUT is a terminal;',
	2170	'redirecting to /dev/null');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2171	close STDOUT;
	2172	open STDOUT, '>', '/dev/null'
	2173	or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
	2174	}
	2175	if ( -t STDERR ) {
212 by Daniel Nichter Update Daemon in all tools (bug 944420).	2176	PTDEBUG && _d('No log file and STDERR is a terminal;',
	2177	'redirecting to /dev/null');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2178	close STDERR;
	2179	open STDERR, '>', '/dev/null'
	2180	or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
	2181	}
	2182	}
	2183
	2184	return;
	2185	}
	2186
	2187	sub check_PID_file {
	2188	my ( $self, $file ) = @_;
	2189	my $PID_file = $self ? $self->{PID_file} : $file;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2190	PTDEBUG && _d('Checking PID file', $PID_file);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2191	if ( $PID_file && -f $PID_file ) {
	2192	my $pid;
94.18.3 by Daniel Nichter Update Daemon.pm in all tools.	2193	eval {
	2194	chomp($pid = (slurp_file($PID_file) \|\| ''));
	2195	};
	2196	if ( $EVAL_ERROR ) {
	2197	die "The PID file $PID_file already exists but it cannot be read: "
	2198	. $EVAL_ERROR;
	2199	}
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2200	PTDEBUG && _d('PID file exists; it contains PID', $pid);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2201	if ( $pid ) {
	2202	my $pid_is_alive = kill 0, $pid;
	2203	if ( $pid_is_alive ) {
	2204	die "The PID file $PID_file already exists "
	2205	. " and the PID that it contains, $pid, is running";
	2206	}
	2207	else {
	2208	warn "Overwriting PID file $PID_file because the PID that it "
	2209	. "contains, $pid, is not running";
	2210	}
	2211	}
	2212	else {
	2213	die "The PID file $PID_file already exists but it does not "
	2214	. "contain a PID";
	2215	}
	2216	}
	2217	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2218	PTDEBUG && _d('No PID file');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2219	}
	2220	return;
	2221	}
	2222
	2223	sub make_PID_file {
	2224	my ( $self ) = @_;
	2225	if ( exists $self->{child} ) {
	2226	die "Do not call Daemon::make_PID_file() for daemonized scripts";
	2227	}
	2228	$self->_make_PID_file();
	2229	$self->{PID_owner} = $PID;
	2230	return;
	2231	}
	2232
	2233	sub _make_PID_file {
	2234	my ( $self ) = @_;
	2235
	2236	my $PID_file = $self->{PID_file};
	2237	if ( !$PID_file ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2238	PTDEBUG && _d('No PID file to create');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2239	return;
	2240	}
	2241
	2242	$self->check_PID_file();
	2243
	2244	open my $PID_FH, '>', $PID_file
	2245	or die "Cannot open PID file $PID_file: $OS_ERROR";
	2246	print $PID_FH $PID
	2247	or die "Cannot print to PID file $PID_file: $OS_ERROR";
	2248	close $PID_FH
	2249	or die "Cannot close PID file $PID_file: $OS_ERROR";
	2250
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2251	PTDEBUG && _d('Created PID file:', $self->{PID_file});
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2252	return;
	2253	}
	2254
	2255	sub _remove_PID_file {
	2256	my ( $self ) = @_;
	2257	if ( $self->{PID_file} && -f $self->{PID_file} ) {
	2258	unlink $self->{PID_file}
	2259	or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2260	PTDEBUG && _d('Removed PID file');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2261	}
	2262	else {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	2263	PTDEBUG && _d('No PID to remove');
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2264	}
	2265	return;
	2266	}
	2267
	2268	sub DESTROY {
	2269	my ( $self ) = @_;
	2270
	2271	$self->_remove_PID_file() if ($self->{PID_owner} \|\| 0) == $PID;
	2272
	2273	return;
	2274	}
	2275
94.18.3 by Daniel Nichter Update Daemon.pm in all tools.	2276	sub slurp_file {
	2277	my ($file) = @_;
	2278	return unless $file;
	2279	open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
	2280	return do { local $/; <$fh> };
	2281	}
	2282
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2283	sub _d {
	2284	my ($package, undef, $line) = caller 0;
	2285	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
	2286	map { defined $_ ? $_ : 'undef' }
	2287	@_;
	2288	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
	2289	}
	2290
	2291	1;
19 by Daniel Nichter Update all modules in all tools. Remove pt-table-usage. Make update-modules ignore non-Perl tools.	2292	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	2293	# ###########################################################################
	2294	# End Daemon package
	2295	# ###########################################################################
	2296
	2297	# ###########################################################################
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2298	# HTTPMicro package
	2299	# This package is a copy without comments from the original. The original
	2300	# with comments and its test file can be found in the Bazaar repository at,
	2301	# lib/HTTPMicro.pm
	2302	# t/lib/HTTPMicro.t
	2303	# See https://launchpad.net/percona-toolkit for more information.
	2304	# ###########################################################################
	2305	{
	2306
350.1.18 by fraserb at gmail Fix several test failures by doing s/HTTP::Micro/HTTPMicro/	2307	package HTTPMicro;
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2308	BEGIN {
350.1.18 by fraserb at gmail Fix several test failures by doing s/HTTP::Micro/HTTPMicro/	2309	$HTTPMicro::VERSION = '0.001';
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2310	}
	2311	use strict;
	2312	use warnings;
	2313
	2314	use Carp ();
	2315
	2316
	2317	my @attributes;
	2318	BEGIN {
	2319	@attributes = qw(agent timeout);
	2320	no strict 'refs';
	2321	for my $accessor ( @attributes ) {
	2322	*{$accessor} = sub {
	2323	@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
	2324	};
	2325	}
	2326	}
	2327
	2328	sub new {
	2329	my($class, %args) = @_;
	2330	(my $agent = $class) =~ s{::}{-}g;
	2331	my $self = {
	2332	agent => $agent . "/" . ($class->VERSION \|\| 0),
	2333	timeout => 60,
	2334	};
	2335	for my $key ( @attributes ) {
	2336	$self->{$key} = $args{$key} if exists $args{$key}
	2337	}
	2338	return bless $self, $class;
	2339	}
	2340
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2341	my %DefaultPort = (
	2342	http => 80,
	2343	https => 443,
	2344	);
	2345
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2346	sub request {
	2347	my ($self, $method, $url, $args) = @_;
	2348	@_ == 3 \|\| (@_ == 4 && ref $args eq 'HASH')
	2349	or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
	2350	$args \|\|= {}; # we keep some state in this during _request
	2351
	2352	my $response;
	2353	for ( 0 .. 1 ) {
	2354	$response = eval { $self->_request($method, $url, $args) };
	2355	last unless $@ && $method eq 'GET'
	2356	&& $@ =~ m{^(?:Socket closed\|Unexpected end)};
	2357	}
	2358
	2359	if (my $e = "$@") {
	2360	$response = {
	2361	success => q{},
	2362	status => 599,
	2363	reason => 'Internal Exception',
	2364	content => $e,
	2365	headers => {
	2366	'content-type' => 'text/plain',
	2367	'content-length' => length $e,
	2368	}
	2369	};
	2370	}
	2371	return $response;
	2372	}
	2373
	2374	sub _request {
	2375	my ($self, $method, $url, $args) = @_;
	2376
	2377	my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
	2378
	2379	my $request = {
	2380	method => $method,
	2381	scheme => $scheme,
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2382	host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2383	uri => $path_query,
	2384	headers => {},
	2385	};
	2386
350.1.18 by fraserb at gmail Fix several test failures by doing s/HTTP::Micro/HTTPMicro/	2387	my $handle = HTTPMicro::Handle->new(timeout => $self->{timeout});
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2388
	2389	$handle->connect($scheme, $host, $port);
	2390
	2391	$self->_prepare_headers_and_cb($request, $args);
	2392	$handle->write_request_header(@{$request}{qw/method uri headers/});
	2393	$handle->write_content_body($request) if $request->{content};
	2394
	2395	my $response;
	2396	do { $response = $handle->read_response_header }
	2397	until (substr($response->{status},0,1) ne '1');
	2398
	2399	if (!($method eq 'HEAD' \|\| $response->{status} =~ /^[23]04/)) {
	2400	$response->{content} = '';
	2401	$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
	2402	}
	2403
	2404	$handle->close;
	2405	$response->{success} = substr($response->{status},0,1) eq '2';
	2406	return $response;
	2407	}
	2408
	2409	sub _prepare_headers_and_cb {
	2410	my ($self, $request, $args) = @_;
	2411
	2412	for ($args->{headers}) {
	2413	next unless defined;
	2414	while (my ($k, $v) = each %$_) {
	2415	$request->{headers}{lc $k} = $v;
	2416	}
	2417	}
	2418	$request->{headers}{'host'} = $request->{host_port};
	2419	$request->{headers}{'connection'} = "close";
	2420	$request->{headers}{'user-agent'} \|\|= $self->{agent};
	2421
	2422	if (defined $args->{content}) {
	2423	$request->{headers}{'content-type'} \|\|= "application/octet-stream";
	2424	utf8::downgrade($args->{content}, 1)
	2425	or Carp::croak(q/Wide character in request message body/);
	2426	$request->{headers}{'content-length'} = length $args->{content};
	2427	$request->{content} = $args->{content};
	2428	}
	2429	return;
	2430	}
	2431
	2432	sub _split_url {
	2433	my $url = pop;
	2434
	2435	my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#])([^#])>
	2436	or Carp::croak(qq/Cannot parse URL: '$url'/);
	2437
	2438	$scheme = lc $scheme;
	2439	$path_query = "/$path_query" unless $path_query =~ m<\A/>;
	2440
	2441	my $host = (length($authority)) ? lc $authority : 'localhost';
	2442	$host =~ s/\A[^@]*@//; # userinfo
	2443	my $port = do {
	2444	$host =~ s/:([0-9]*)\z// && length $1
	2445	? $1
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2446	: $DefaultPort{$scheme}
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2447	};
	2448
	2449	return ($scheme, $host, $port, $path_query);
	2450	}
	2451
	2452	package
350.1.18 by fraserb at gmail Fix several test failures by doing s/HTTP::Micro/HTTPMicro/	2453	HTTPMicro::Handle; # hide from PAUSE/indexers
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2454	use strict;
	2455	use warnings;
	2456
	2457	use Carp qw[croak];
	2458	use Errno qw[EINTR EPIPE];
	2459	use IO::Socket qw[SOCK_STREAM];
	2460
	2461	sub BUFSIZE () { 32768 }
	2462
	2463	my $Printable = sub {
	2464	local $_ = shift;
	2465	s/\r/\\r/g;
	2466	s/\n/\\n/g;
	2467	s/\t/\\t/g;
	2468	s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
	2469	$_;
	2470	};
	2471
	2472	sub new {
	2473	my ($class, %args) = @_;
	2474	return bless {
	2475	rbuf => '',
	2476	timeout => 60,
	2477	max_line_size => 16384,
	2478	%args
	2479	}, $class;
	2480	}
	2481
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2482	my $ssl_verify_args = {
	2483	check_cn => "when_only",
	2484	wildcards_in_alt => "anywhere",
	2485	wildcards_in_cn => "anywhere"
	2486	};
	2487
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2488	sub connect {
	2489	@_ == 4 \|\| croak(q/Usage: $handle->connect(scheme, host, port)/);
	2490	my ($self, $scheme, $host, $port) = @_;
	2491
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2492	if ( $scheme eq 'https' ) {
	2493	eval "require IO::Socket::SSL"
	2494	unless exists $INC{'IO/Socket/SSL.pm'};
	2495	croak(qq/IO::Socket::SSL must be installed for https support\n/)
	2496	unless $INC{'IO/Socket/SSL.pm'};
	2497	}
	2498	elsif ( $scheme ne 'http' ) {
	2499	croak(qq/Unsupported URL scheme '$scheme'\n/);
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2500	}
	2501
	2502	$self->{fh} = 'IO::Socket::INET'->new(
	2503	PeerHost => $host,
	2504	PeerPort => $port,
	2505	Proto => 'tcp',
	2506	Type => SOCK_STREAM,
	2507	Timeout => $self->{timeout}
	2508	) or croak(qq/Could not connect to '$host:$port': $@/);
	2509
	2510	binmode($self->{fh})
	2511	or croak(qq/Could not binmode() socket: '$!'/);
	2512
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2513	if ( $scheme eq 'https') {
	2514	IO::Socket::SSL->start_SSL($self->{fh});
	2515	ref($self->{fh}) eq 'IO::Socket::SSL'
	2516	or die(qq/SSL connection failed for $host\n/);
395.1.8 by Brian Fraser HTTPMicro: Inline part of IO::Socket::SSL for cases when the local version of the module isn't high enough to support ->verify_hostname(), like in centos5	2517	if ( $self->{fh}->can("verify_hostname") ) {
	2518	$self->{fh}->verify_hostname( $host, $ssl_verify_args );
	2519	}
	2520	else {
	2521	my $fh = $self->{fh};
	2522	_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
	2523	or die(qq/SSL certificate not valid for $host\n/);
	2524	}
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	2525	}
	2526
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2527	$self->{host} = $host;
	2528	$self->{port} = $port;
	2529
	2530	return $self;
	2531	}
	2532
	2533	sub close {
	2534	@_ == 1 \|\| croak(q/Usage: $handle->close()/);
	2535	my ($self) = @_;
	2536	CORE::close($self->{fh})
	2537	or croak(qq/Could not close socket: '$!'/);
	2538	}
	2539
	2540	sub write {
	2541	@_ == 2 \|\| croak(q/Usage: $handle->write(buf)/);
	2542	my ($self, $buf) = @_;
	2543
	2544	my $len = length $buf;
	2545	my $off = 0;
	2546
	2547	local $SIG{PIPE} = 'IGNORE';
	2548
	2549	while () {
	2550	$self->can_write
	2551	or croak(q/Timed out while waiting for socket to become ready for writing/);
	2552	my $r = syswrite($self->{fh}, $buf, $len, $off);
	2553	if (defined $r) {
	2554	$len -= $r;
	2555	$off += $r;
	2556	last unless $len > 0;
	2557	}
	2558	elsif ($! == EPIPE) {
	2559	croak(qq/Socket closed by remote server: $!/);
	2560	}
	2561	elsif ($! != EINTR) {
	2562	croak(qq/Could not write to socket: '$!'/);
	2563	}
	2564	}
	2565	return $off;
	2566	}
	2567
	2568	sub read {
	2569	@_ == 2 \|\| @_ == 3 \|\| croak(q/Usage: $handle->read(len)/);
	2570	my ($self, $len) = @_;
	2571
	2572	my $buf = '';
	2573	my $got = length $self->{rbuf};
	2574
	2575	if ($got) {
	2576	my $take = ($got < $len) ? $got : $len;
	2577	$buf = substr($self->{rbuf}, 0, $take, '');
	2578	$len -= $take;
	2579	}
	2580
	2581	while ($len > 0) {
	2582	$self->can_read
	2583	or croak(q/Timed out while waiting for socket to become ready for reading/);
	2584	my $r = sysread($self->{fh}, $buf, $len, length $buf);
	2585	if (defined $r) {
	2586	last unless $r;
	2587	$len -= $r;
	2588	}
	2589	elsif ($! != EINTR) {
	2590	croak(qq/Could not read from socket: '$!'/);
2591	}
2592	}
2593	if ($len) {
2594	croak(q/Unexpected end of stream/);
2595	}
2596	return $buf;
2597	}
2598
2599	sub readline {
2600	@_ == 1 \|\| croak(q/Usage: $handle->readline()/);
2601	my ($self) = @_;
2602
2603	while () {
2604	if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
2605	return $1;
2606	}
2607	$self->can_read
2608	or croak(q/Timed out while waiting for socket to become ready for reading/);
2609	my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
2610	if (defined $r) {
2611	last unless $r;
2612	}
2613	elsif ($! != EINTR) {
2614	croak(qq/Could not read from socket: '$!'/);
2615	}
2616	}
2617	croak(q/Unexpected end of stream while looking for line/);
2618	}
2619
2620	sub read_header_lines {
2621	@_ == 1 \|\| @_ == 2 \|\| croak(q/Usage: $handle->read_header_lines([headers])/);
2622	my ($self, $headers) = @_;
2623	$headers \|\|= {};
2624	my $lines = 0;
2625	my $val;
2626
2627	while () {
2628	my $line = $self->readline;
2629
2630	if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
2631	my ($field_name) = lc $1;
2632	$val = \($headers->{$field_name} = $2);
2633	}
2634	elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
2635	$val
2636	or croak(q/Unexpected header continuation line/);
2637	next unless length $1;
2638	$$val .= ' ' if length $$val;
2639	$$val .= $1;
2640	}
2641	elsif ($line =~ /\A \x0D?\x0A \z/x) {
2642	last;
2643	}
2644	else {
2645	croak(q/Malformed header line: / . $Printable->($line));
2646	}
2647	}
2648	return $headers;
2649	}
2650
2651	sub write_header_lines {
2652	(@_ == 2 && ref $_[1] eq 'HASH') \|\| croak(q/Usage: $handle->write_header_lines(headers)/);
2653	my($self, $headers) = @_;
2654
2655	my $buf = '';
2656	while (my ($k, $v) = each %$headers) {
2657	my $field_name = lc $k;
2658	$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
2659	or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
2660	$field_name =~ s/\b(\w)/\u$1/g;
2661	$buf .= "$field_name: $v\x0D\x0A";
2662	}
2663	$buf .= "\x0D\x0A";
2664	return $self->write($buf);
2665	}
2666
2667	sub read_content_body {
2668	@_ == 3 \|\| @_ == 4 \|\| croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
2669	my ($self, $cb, $response, $len) = @_;
2670	$len \|\|= $response->{headers}{'content-length'};
2671
2672	croak("No content-length in the returned response, and this "
2673	. "UA doesn't implement chunking") unless defined $len;
2674
2675	while ($len > 0) {
2676	my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
2677	$cb->($self->read($read), $response);
2678	$len -= $read;
2679	}
2680
2681	return;
2682	}
2683
2684	sub write_content_body {
2685	@_ == 2 \|\| croak(q/Usage: $handle->write_content_body(request)/);
2686	my ($self, $request) = @_;
2687	my ($len, $content_length) = (0, $request->{headers}{'content-length'});
2688
2689	$len += $self->write($request->{content});
2690
2691	$len == $content_length
2692	or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
2693
2694	return $len;
2695	}
2696
2697	sub read_response_header {
2698	@_ == 1 \|\| croak(q/Usage: $handle->read_response_header()/);
2699	my ($self) = @_;
2700
2701	my $line = $self->readline;
2702
2703	$line =~ /\A (HTTP\/(0\d+\.0\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
2704	or croak(q/Malformed Status-Line: / . $Printable->($line));
2705
2706	my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
2707
2708	return {
2709	status => $status,
2710	reason => $reason,
2711	headers => $self->read_header_lines,
2712	protocol => $protocol,
2713	};
2714	}
2715
2716	sub write_request_header {
2717	@_ == 4 \|\| croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
2718	my ($self, $method, $request_uri, $headers) = @_;
2719
2720	return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
2721	+ $self->write_header_lines($headers);
2722	}
2723
2724	sub _do_timeout {
2725	my ($self, $type, $timeout) = @_;
2726	$timeout = $self->{timeout}
2727	unless defined $timeout && $timeout >= 0;
2728
2729	my $fd = fileno $self->{fh};
2730	defined $fd && $fd >= 0
2731	or croak(q/select(2): 'Bad file descriptor'/);
2732
2733	my $initial = time;
2734	my $pending = $timeout;
2735	my $nfound;
2736
2737	vec(my $fdset = '', $fd, 1) = 1;
2738
2739	while () {
2740	$nfound = ($type eq 'read')
2741	? select($fdset, undef, undef, $pending)
2742	: select(undef, $fdset, undef, $pending) ;
2743	if ($nfound == -1) {
2744	$! == EINTR
2745	or croak(qq/select(2): '$!'/);
2746	redo if !$timeout \|\| ($pending = $timeout - (time - $initial)) > 0;
2747	$nfound = 0;
2748	}
2749	last;
2750	}
2751	$! = 0;
2752	return $nfound;
2753	}
2754
2755	sub can_read {
2756	@_ == 1 \|\| @_ == 2 \|\| croak(q/Usage: $handle->can_read([timeout])/);
2757	my $self = shift;
2758	return $self->_do_timeout('read', @_)
2759	}
2760
2761	sub can_write {
2762	@_ == 1 \|\| @_ == 2 \|\| croak(q/Usage: $handle->can_write([timeout])/);
2763	my $self = shift;
2764	return $self->_do_timeout('write', @_)
2765	}
2766
395.1.8 by Brian Fraser HTTPMicro: Inline part of IO::Socket::SSL for cases when the local version of the module isn't high enough to support ->verify_hostname(), like in centos5	2767	my $prog = <<'EOP';
	2768	BEGIN {
	2769	if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
	2770	CAN_IPV6 = \IO::Socket::SSL::CAN_IPV6;
	2771	}
	2772	else {
	2773	constant->import( CAN_IPV6 => '' );
	2774	}
	2775	my %const = (
	2776	NID_CommonName => 13,
	2777	GEN_DNS => 2,
	2778	GEN_IPADD => 7,
	2779	);
	2780	while ( my ($name,$value) = each %const ) {
	2781	no strict 'refs';
	2782	*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) \|\| sub { $value };
	2783	}
	2784	}
	2785	{
	2786	my %dispatcher = (
	2787	issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
	2788	subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
	2789	);
	2790	if ( $Net::SSLeay::VERSION >= 1.30 ) {
	2791	$dispatcher{commonName} = sub {
	2792	my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
	2793	Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
	2794	$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
	2795	$cn;
	2796	}
	2797	} else {
	2798	$dispatcher{commonName} = sub {
	2799	croak "you need at least Net::SSLeay version 1.30 for getting commonName"
	2800	}
	2801	}
	2802
	2803	if ( $Net::SSLeay::VERSION >= 1.33 ) {
	2804	$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
	2805	} else {
	2806	$dispatcher{subjectAltNames} = sub {
	2807	return;
	2808	};
	2809	}
	2810
	2811	$dispatcher{authority} = $dispatcher{issuer};
	2812	$dispatcher{owner} = $dispatcher{subject};
	2813	$dispatcher{cn} = $dispatcher{commonName};
	2814
	2815	sub _peer_certificate {
	2816	my ($self, $field) = @_;
	2817	my $ssl = $self->_get_ssl_object or return;
	2818
	2819	my $cert = ${*$self}{_SSL_certificate}
	2820	\|\|= Net::SSLeay::get_peer_certificate($ssl)
	2821	or return $self->error("Could not retrieve peer certificate");
	2822
	2823	if ($field) {
	2824	my $sub = $dispatcher{$field} or croak
	2825	"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
	2826	"\nMaybe you need to upgrade your Net::SSLeay";
	2827	return $sub->($cert);
	2828	} else {
	2829	return $cert
	2830	}
2831	}
2832
2833
2834	my %scheme = (
2835	ldap => {
2836	wildcards_in_cn => 0,
2837	wildcards_in_alt => 'leftmost',
2838	check_cn => 'always',
2839	},
2840	http => {
2841	wildcards_in_cn => 'anywhere',
2842	wildcards_in_alt => 'anywhere',
2843	check_cn => 'when_only',
2844	},
2845	smtp => {
2846	wildcards_in_cn => 0,
2847	wildcards_in_alt => 0,
2848	check_cn => 'always'
2849	},
2850	none => {}, # do not check
2851	);
2852
2853	$scheme{www} = $scheme{http}; # alias
2854	$scheme{xmpp} = $scheme{http}; # rfc 3920
2855	$scheme{pop3} = $scheme{ldap}; # rfc 2595
2856	$scheme{imap} = $scheme{ldap}; # rfc 2595
2857	$scheme{acap} = $scheme{ldap}; # rfc 2595
2858	$scheme{nntp} = $scheme{ldap}; # rfc 4642
2859	$scheme{ftp} = $scheme{http}; # rfc 4217
2860
2861
2862	sub _verify_hostname_of_cert {
2863	my $identity = shift;
2864	my $cert = shift;
2865	my $scheme = shift \|\| 'none';
2866	if ( ! ref($scheme) ) {
2867	$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
2868	}
2869
2870	return 1 if ! %$scheme; # 'none'
2871
2872	my $commonName = $dispatcher{cn}->($cert);
2873	my @altNames = $dispatcher{subjectAltNames}->($cert);
2874
2875	if ( my $sub = $scheme->{callback} ) {
2876	return $sub->($identity,$commonName,@altNames);
2877	}
2878
2879
2880	my $ipn;
2881	if ( CAN_IPV6 and $identity =~m{:} ) {
2882	$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
2883	or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
2884	} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
2885	$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
2886	} else {
2887	if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
2888	$identity =~m{\0} and croak("name '$identity' has \\0 byte");
2889	$identity = IO::Socket::SSL::idn_to_ascii($identity) or
2890	croak "Warning: Given name '$identity' could not be converted to IDNA!";
2891	}
2892	}
2893
2894	my $check_name = sub {
2895	my ($name,$identity,$wtyp) = @_;
2896	$wtyp \|\|= '';
2897	my $pattern;
2898	if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-])\(.+)} ) {
2899	$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
2900	} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
2901	$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
2902	} else {
2903	$pattern = qr{^\Q$name\E$}i;
2904	}
2905	return $identity =~ $pattern;
2906	};
2907
2908	my $alt_dnsNames = 0;
2909	while (@altNames) {
2910	my ($type, $name) = splice (@altNames, 0, 2);
2911	if ( $ipn and $type == GEN_IPADD ) {
2912	return 1 if $ipn eq $name;
2913
2914	} elsif ( ! $ipn and $type == GEN_DNS ) {
2915	$name =~s/\s+$//; $name =~s/^\s+//;
2916	$alt_dnsNames++;
2917	$check_name->($name,$identity,$scheme->{wildcards_in_alt})
2918	and return 1;
2919	}
2920	}
2921
2922	if ( ! $ipn and (
2923	$scheme->{check_cn} eq 'always' or
2924	$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
2925	$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
2926	and return 1;
2927	}
2928
2929	return 0; # no match
2930	}
2931	}
2932	EOP
2933
2934	eval { require IO::Socket::SSL };
2935	if ( $INC{"IO/Socket/SSL.pm"} ) {
2936	eval $prog;
2937	die $@ if $@;
2938	}
2939
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2940	1;
	2941	}
	2942	# ###########################################################################
	2943	# End HTTPMicro package
	2944	# ###########################################################################
	2945
	2946	# ###########################################################################
522 by Daniel Nichter Rename Pingback.pm to VersionCheck.pm.	2947	# VersionCheck package
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2948	# This package is a copy without comments from the original. The original
	2949	# with comments and its test file can be found in the Bazaar repository at,
522 by Daniel Nichter Rename Pingback.pm to VersionCheck.pm.	2950	# lib/VersionCheck.pm
	2951	# t/lib/VersionCheck.t
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2952	# See https://launchpad.net/percona-toolkit for more information.
	2953	# ###########################################################################
	2954	{
522 by Daniel Nichter Rename Pingback.pm to VersionCheck.pm.	2955	package VersionCheck;
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2956
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	2957
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2958	use strict;
	2959	use warnings FATAL => 'all';
	2960	use English qw(-no_match_vars);
	2961
	2962	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
	2963
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	2964	use Data::Dumper;
	2965	local $Data::Dumper::Indent = 1;
	2966	local $Data::Dumper::Sortkeys = 1;
	2967	local $Data::Dumper::Quotekeys = 0;
	2968
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	2969	use Digest::MD5 qw(md5_hex);
	2970	use Sys::Hostname qw(hostname);
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	2971	use File::Basename qw();
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	2972	use File::Spec;
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	2973	use FindBin qw();
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	2974
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2975	eval {
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	2976	require Percona::Toolkit;
350.1.18 by fraserb at gmail Fix several test failures by doing s/HTTP::Micro/HTTPMicro/	2977	require HTTPMicro;
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	2978	};
	2979
526.1.4 by Daniel Nichter Change version_check_file() to prefer global system dirs first.	2980	{
	2981	my $file = 'percona-version-check';
	2982	my $home = $ENV{HOME} \|\| $ENV{HOMEPATH} \|\| $ENV{USERPROFILE} \|\| '.';
	2983	my @vc_dirs = (
	2984	'/etc/percona',
	2985	'/etc/percona-toolkit',
	2986	'/tmp',
	2987	"$home",
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	2988	);
526.1.4 by Daniel Nichter Change version_check_file() to prefer global system dirs first.	2989
	2990	sub version_check_file {
	2991	foreach my $dir ( @vc_dirs ) {
	2992	if ( -d $dir && -w $dir ) {
	2993	PTDEBUG && _d('Version check file', $file, 'in', $dir);
	2994	return $dir . '/' . $file;
	2995	}
	2996	}
	2997	PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
	2998	return $file; # in the CWD
	2999	}
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3000	}
	3001
	3002	sub version_check_time_limit {
	3003	return 60 * 60 * 24; # one day
	3004	}
	3005
	3006
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3007	sub version_check {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3008	my (%args) = @_;
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3009
	3010	my $instances = $args{instances} \|\| [];
	3011	my $instances_to_check;
	3012
526.1.13 by Daniel Nichter Check for ../../.bzr for when a tool is ran as a module in a test.	3013	PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	3014	if ( !$args{force} ) {
526.1.13 by Daniel Nichter Check for ../../.bzr for when a tool is ran as a module in a test.	3015	if ( $FindBin::Bin
	3016	&& (-d "$FindBin::Bin/../.bzr" \|\| -d "$FindBin::Bin/../../.bzr") ) {
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	3017	PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3018	return;
	3019	}
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	3020	}
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3021
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	3022	eval {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3023	foreach my $instance ( @$instances ) {
	3024	my ($name, $id) = get_instance_id($instance);
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3025	$instance->{name} = $name;
	3026	$instance->{id} = $id;
	3027	}
	3028
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3029	push @$instances, { name => 'system', id => 0 };
	3030
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3031	$instances_to_check = get_instances_to_check(
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3032	instances => $instances,
	3033	vc_file => $args{vc_file}, # testing
	3034	now => $args{now}, # testing
	3035	);
	3036	PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
	3037	return unless @$instances_to_check;
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3038
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3039	my $protocol = 'https'; # optimistic, but...
	3040	eval { require IO::Socket::SSL; };
	3041	if ( $EVAL_ERROR ) {
	3042	PTDEBUG && _d($EVAL_ERROR);
	3043	$protocol = 'http';
435.5.1 by fraserb at gmail Removed optional_value, made --version-check have default: off, updated the tools and documentation with the changes, and added the auto value to Pingback.pm	3044	}
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3045	PTDEBUG && _d('Using', $protocol);
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3046
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3047	my $advice = pingback(
	3048	instances => $instances_to_check,
	3049	protocol => $protocol,
	3050	url => $args{url} # testing
	3051	\|\| $ENV{PERCONA_VERSION_CHECK_URL} # testing
	3052	\|\| "$protocol://v.percona.com",
	3053	);
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3054	if ( $advice ) {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3055	PTDEBUG && _d('Advice:', Dumper($advice));
	3056	if ( scalar @$advice > 1) {
	3057	print "\n# " . scalar @$advice . " software updates are "
	3058	. "available:\n";
	3059	}
	3060	else {
	3061	print "\n# A software update is available:\n";
	3062	}
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	3063	print join("\n", map { "# * $_" } @$advice), "\n\n";
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3064	}
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3065	};
	3066	if ( $EVAL_ERROR ) {
	3067	PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
	3068	}
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3069
526.1.10 by Daniel Nichter Update VersionCheck in all tools.	3070	if ( @$instances_to_check ) {
	3071	eval {
	3072	update_check_times(
	3073	instances => $instances_to_check,
	3074	vc_file => $args{vc_file}, # testing
	3075	now => $args{now}, # testing
	3076	);
	3077	};
	3078	if ( $EVAL_ERROR ) {
	3079	PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
	3080	}
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3081	}
	3082
	3083	if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
	3084	warn "Exiting because the PTDEBUG_VERSION_CHECK "
	3085	. "environment variable is defined.\n";
	3086	exit 255;
	3087	}
	3088
	3089	return;
	3090	}
	3091
	3092	sub get_instances_to_check {
	3093	my (%args) = @_;
	3094
	3095	my $instances = $args{instances};
	3096	my $now = $args{now} \|\| int(time);
	3097	my $vc_file = $args{vc_file} \|\| version_check_file();
	3098
	3099	if ( !-f $vc_file ) {
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3100	PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
	3101	'version checking all instances');
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3102	return $instances;
	3103	}
	3104
	3105	open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
	3106	chomp(my $file_contents = do { local $/ = undef; <$fh> });
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3107	PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3108	close $fh;
	3109	my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
	3110
	3111	my $check_time_limit = version_check_time_limit();
	3112	my @instances_to_check;
	3113	foreach my $instance ( @$instances ) {
	3114	my $last_check_time = $last_check_time_for{ $instance->{id} };
	3115	PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
526.1.3 by Daniel Nichter Fix get_perl_module_version(). Add 'hours until next check' to debug output.	3116	$last_check_time, 'now', $now, 'diff', $now - ($last_check_time \|\| 0),
	3117	'hours until next check',
	3118	sprintf '%.2f',
	3119	($check_time_limit - ($now - ($last_check_time \|\| 0))) / 3600);
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3120	if ( !defined $last_check_time
	3121	\|\| ($now - $last_check_time) >= $check_time_limit ) {
	3122	PTDEBUG && _d('Time to check', Dumper($instance));
	3123	push @instances_to_check, $instance;
	3124	}
	3125	}
	3126
	3127	return \@instances_to_check;
	3128	}
	3129
	3130	sub update_check_times {
	3131	my (%args) = @_;
	3132
	3133	my $instances = $args{instances};
	3134	my $now = $args{now} \|\| int(time);
	3135	my $vc_file = $args{vc_file} \|\| version_check_file();
	3136	PTDEBUG && _d('Updating last check time:', $now);
	3137
567 by Daniel Nichter Hot-fix --version-check.	3138	my %all_instances = map {
	3139	$_->{id} => { name => $_->{name}, ts => $now }
	3140	} @$instances;
	3141
	3142	if ( -f $vc_file ) {
	3143	open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
	3144	my $contents = do { local $/ = undef; <$fh> };
	3145	close $fh;
	3146
	3147	foreach my $line ( split("\n", ($contents \|\| '')) ) {
	3148	my ($id, $ts) = split(',', $line);
	3149	if ( !exists $all_instances{$id} ) {
	3150	$all_instances{$id} = { ts => $ts }; # original ts, not updated
	3151	}
	3152	}
	3153	}
	3154
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3155	open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
567 by Daniel Nichter Hot-fix --version-check.	3156	foreach my $id ( sort keys %all_instances ) {
	3157	PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
	3158	print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3159	}
	3160	close $fh;
	3161
	3162	return;
	3163	}
	3164
	3165	sub get_instance_id {
	3166	my ($instance) = @_;
	3167
	3168	my $dbh = $instance->{dbh};
	3169	my $dsn = $instance->{dsn};
	3170
	3171	my $sql = q{SELECT CONCAT(@@hostname, @@port)};
	3172	PTDEBUG && _d($sql);
	3173	my ($name) = eval { $dbh->selectrow_array($sql) };
	3174	if ( $EVAL_ERROR ) {
	3175	PTDEBUG && _d($EVAL_ERROR);
	3176	$sql = q{SELECT @@hostname};
	3177	PTDEBUG && _d($sql);
	3178	($name) = eval { $dbh->selectrow_array($sql) };
	3179	if ( $EVAL_ERROR ) {
	3180	PTDEBUG && _d($EVAL_ERROR);
	3181	$name = ($dsn->{h} \|\| 'localhost') . ($dsn->{P} \|\| 3306);
	3182	}
395.1.7 by Brian Fraser Minor update to --version-check: Let the user know if there were no suggestions	3183	else {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3184	$sql = q{SHOW VARIABLES LIKE 'port'};
	3185	PTDEBUG && _d($sql);
	3186	my (undef, $port) = eval { $dbh->selectrow_array($sql) };
	3187	PTDEBUG && _d('port:', $port);
	3188	$name .= $port \|\| '';
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3189	}
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3190	}
	3191	my $id = md5_hex($name);
	3192
567 by Daniel Nichter Hot-fix --version-check.	3193	PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3194
	3195	return $name, $id;
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3196	}
	3197
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3198
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3199	sub pingback {
	3200	my (%args) = @_;
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3201	my @required_args = qw(url instances);
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3202	foreach my $arg ( @required_args ) {
	3203	die "I need a $arg arugment" unless $args{$arg};
	3204	}
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3205	my $url = $args{url};
	3206	my $instances = $args{instances};
	3207
526.1.6 by Daniel Nichter Don't try https and http: use https if possible, else http. Lower timeout from 5 to 3 seconds. Start updating/fixing pt-archiver/version_check.t.	3208	my $ua = $args{ua} \|\| HTTPMicro->new( timeout => 3 );
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3209
	3210	my $response = $ua->request('GET', $url);
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3211	PTDEBUG && _d('Server response:', Dumper($response));
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3212	die "No response from GET $url"
	3213	if !$response;
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	3214	die("GET on $url returned HTTP status $response->{status}; expected 200\n",
	3215	($response->{content} \|\| '')) if $response->{status} != 200;
	3216	die("GET on $url did not return any programs to check")
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3217	if !$response->{content};
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3218
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3219	my $items = parse_server_response(
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3220	response => $response->{content}
	3221	);
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3222	die "Failed to parse server requested programs: $response->{content}"
	3223	if !scalar keys %$items;
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3224
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3225	my $versions = get_versions(
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3226	items => $items,
	3227	instances => $instances,
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3228	);
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3229	die "Failed to get any program versions; should have at least gotten Perl"
	3230	if !scalar keys %$versions;
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3231
	3232	my $client_content = encode_client_response(
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3233	items => $items,
	3234	versions => $versions,
	3235	general_id => md5_hex( hostname() ),
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3236	);
	3237
	3238	my $client_response = {
	3239	headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
	3240	content => $client_content,
	3241	};
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3242	PTDEBUG && _d('Client response:', Dumper($client_response));
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3243
	3244	$response = $ua->request('POST', $url, $client_response);
	3245	PTDEBUG && _d('Server suggestions:', Dumper($response));
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3246	die "No response from POST $url $client_response"
	3247	if !$response;
	3248	die "POST $url returned HTTP status $response->{status}; expected 200"
	3249	if $response->{status} != 200;
	3250
	3251	return unless $response->{content};
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3252
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3253	$items = parse_server_response(
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3254	response => $response->{content},
	3255	split_vars => 0,
	3256	);
350.1.23 by Daniel Nichter Put everything in Pingback::version_check(). Change HTTP::Micro to HTTPMicro in pingback(). Simplify time_to_check() a little and add more debug. Fix Pingback.t now that client response doesn't have TYPE and no response causes die.	3257	die "Failed to parse server suggestions: $response->{content}"
	3258	if !scalar keys %$items;
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3259	my @suggestions = map { $_->{vars} }
	3260	sort { $a->{item} cmp $b->{item} }
	3261	values %$items;
	3262
	3263	return \@suggestions;
	3264	}
	3265
	3266	sub encode_client_response {
	3267	my (%args) = @_;
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3268	my @required_args = qw(items versions general_id);
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3269	foreach my $arg ( @required_args ) {
	3270	die "I need a $arg arugment" unless $args{$arg};
	3271	}
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3272	my ($items, $versions, $general_id) = @args{@required_args};
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3273
	3274	my @lines;
	3275	foreach my $item ( sort keys %$items ) {
	3276	next unless exists $versions->{$item};
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3277	if ( ref($versions->{$item}) eq 'HASH' ) {
	3278	my $mysql_versions = $versions->{$item};
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	3279	for my $id ( sort keys %$mysql_versions ) {
366.2.4 by Daniel Nichter Simplify how Pingback handles MySQL instances. Remove Percona::Toolkit::slurp_file() because it was causing 'sub redefined' errors, probably due to PerconaTest::slurp_file(). Add more PTVCDEBUG statements.	3280	push @lines, join(';', $id, $item, $mysql_versions->{$id});
	3281	}
	3282	}
	3283	else {
	3284	push @lines, join(';', $general_id, $item, $versions->{$item});
	3285	}
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3286	}
	3287
	3288	my $client_response = join("\n", @lines) . "\n";
	3289	return $client_response;
	3290	}
	3291
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3292	sub parse_server_response {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3293	my (%args) = @_;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3294	my @required_args = qw(response);
	3295	foreach my $arg ( @required_args ) {
	3296	die "I need a $arg arugment" unless $args{$arg};
	3297	}
	3298	my ($response) = @args{@required_args};
	3299
	3300	my %items = map {
	3301	my ($item, $type, $vars) = split(";", $_);
	3302	if ( !defined $args{split_vars} \|\| $args{split_vars} ) {
	3303	$vars = [ split(",", ($vars \|\| '')) ];
	3304	}
	3305	$item => {
	3306	item => $item,
	3307	type => $type,
	3308	vars => $vars,
	3309	};
	3310	} split("\n", $response);
	3311
	3312	PTDEBUG && _d('Items:', Dumper(\%items));
	3313
	3314	return \%items;
	3315	}
	3316
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3317	my %sub_for_type = (
	3318	os_version => \&get_os_version,
	3319	perl_version => \&get_perl_version,
	3320	perl_module_version => \&get_perl_module_version,
	3321	mysql_variable => \&get_mysql_variable,
	3322	bin_version => \&get_bin_version,
	3323	);
	3324
	3325	sub valid_item {
	3326	my ($item) = @_;
	3327	return unless $item;
	3328	if ( !exists $sub_for_type{ $item->{type} } ) {
	3329	PTDEBUG && _d('Invalid type:', $item->{type});
	3330	return 0;
	3331	}
	3332	return 1;
	3333	}
	3334
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3335	sub get_versions {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3336	my (%args) = @_;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3337	my @required_args = qw(items);
	3338	foreach my $arg ( @required_args ) {
	3339	die "I need a $arg arugment" unless $args{$arg};
	3340	}
	3341	my ($items) = @args{@required_args};
	3342
	3343	my %versions;
	3344	foreach my $item ( values %$items ) {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3345	next unless valid_item($item);
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3346	eval {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3347	my $version = $sub_for_type{ $item->{type} }->(
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3348	item => $item,
	3349	instances => $args{instances},
	3350	);
	3351	if ( $version ) {
	3352	chomp $version unless ref($version);
	3353	$versions{$item->{item}} = $version;
	3354	}
	3355	};
	3356	if ( $EVAL_ERROR ) {
	3357	PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
	3358	}
	3359	}
	3360
	3361	return \%versions;
	3362	}
	3363
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3364
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3365	sub get_os_version {
	3366	if ( $OSNAME eq 'MSWin32' ) {
	3367	require Win32;
	3368	return Win32::GetOSDisplayName();
	3369	}
	3370
	3371	chomp(my $platform = `uname -s`);
	3372	PTDEBUG && _d('platform:', $platform);
	3373	return $OSNAME unless $platform;
	3374
	3375	chomp(my $lsb_release
	3376	= `which lsb_release 2>/dev/null \| awk '{print \$1}'` \|\| '');
	3377	PTDEBUG && _d('lsb_release:', $lsb_release);
	3378
	3379	my $release = "";
	3380
	3381	if ( $platform eq 'Linux' ) {
	3382	if ( -f "/etc/fedora-release" ) {
	3383	$release = `cat /etc/fedora-release`;
	3384	}
	3385	elsif ( -f "/etc/redhat-release" ) {
	3386	$release = `cat /etc/redhat-release`;
	3387	}
	3388	elsif ( -f "/etc/system-release" ) {
	3389	$release = `cat /etc/system-release`;
	3390	}
	3391	elsif ( $lsb_release ) {
	3392	$release = `$lsb_release -ds`;
	3393	}
	3394	elsif ( -f "/etc/lsb-release" ) {
	3395	$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
	3396	$release =~ s/^\w+="([^"]+)".+/$1/;
	3397	}
	3398	elsif ( -f "/etc/debian_version" ) {
	3399	chomp(my $rel = `cat /etc/debian_version`);
	3400	$release = "Debian $rel";
	3401	if ( -f "/etc/apt/sources.list" ) {
	3402	chomp(my $code_name = `awk '/^deb/ {print \$3}' /etc/apt/sources.list \| awk -F/ '{print \$1}'\| awk 'BEGIN {FS="\|"} {print \$1}' \| sort \| uniq -c \| sort -rn \| head -n1 \| awk '{print \$2}'`);
	3403	$release .= " ($code_name)" if $code_name;
	3404	}
	3405	}
	3406	elsif ( -f "/etc/os-release" ) { # openSUSE
	3407	chomp($release = `grep PRETTY_NAME /etc/os-release`);
	3408	$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
	3409	}
	3410	elsif ( `ls /etc/*release 2>/dev/null` ) {
	3411	if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
	3412	$release = `grep DISTRIB_DESCRIPTION /etc/*release \| head -n1`;
	3413	}
	3414	else {
	3415	$release = `cat /etc/*release \| head -n1`;
	3416	}
	3417	}
	3418	}
	3419	elsif ( $platform =~ m/(?:BSD\|^Darwin)$/ ) {
	3420	my $rel = `uname -r`;
	3421	$release = "$platform $rel";
	3422	}
	3423	elsif ( $platform eq "SunOS" ) {
	3424	my $rel = `head -n1 /etc/release` \|\| `uname -r`;
	3425	$release = "$platform $rel";
	3426	}
	3427
	3428	if ( !$release ) {
3429	PTDEBUG && _d('Failed to get the release, using platform');
3430	$release = $platform;
3431	}
3432	chomp($release);
3433
3434	$release =~ s/^"\|"$//g;
3435
3436	PTDEBUG && _d('OS version =', $release);
3437	return $release;
3438	}
3439
3440	sub get_perl_version {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3441	my (%args) = @_;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3442	my $item = $args{item};
	3443	return unless $item;
	3444
	3445	my $version = sprintf '%vd', $PERL_VERSION;
	3446	PTDEBUG && _d('Perl version', $version);
	3447	return $version;
	3448	}
	3449
	3450	sub get_perl_module_version {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3451	my (%args) = @_;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3452	my $item = $args{item};
	3453	return unless $item;
	3454
526.1.3 by Daniel Nichter Fix get_perl_module_version(). Add 'hours until next check' to debug output.	3455	my $var = '$' . $item->{item} . '::VERSION';
	3456	my $version = eval "use $item->{item}; $var;";
	3457	PTDEBUG && _d('Perl version for', $var, '=', $version);
	3458	return $version;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3459	}
	3460
	3461	sub get_mysql_variable {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3462	return get_from_mysql(
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3463	show => 'VARIABLES',
	3464	@_,
	3465	);
	3466	}
	3467
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3468	sub get_from_mysql {
	3469	my (%args) = @_;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3470	my $show = $args{show};
	3471	my $item = $args{item};
	3472	my $instances = $args{instances};
	3473	return unless $show && $item;
	3474
	3475	if ( !$instances \|\| !@$instances ) {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3476	PTDEBUG && _d('Cannot check', $item,
	3477	'because there are no MySQL instances');
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3478	return;
	3479	}
	3480
	3481	my @versions;
	3482	my %version_for;
	3483	foreach my $instance ( @$instances ) {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3484	next unless $instance->{id}; # special system instance has id=0
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3485	my $dbh = $instance->{dbh};
	3486	local $dbh->{FetchHashKeyName} = 'NAME_lc';
	3487	my $sql = qq/SHOW $show/;
	3488	PTDEBUG && _d($sql);
	3489	my $rows = $dbh->selectall_hashref($sql, 'variable_name');
	3490
	3491	my @versions;
	3492	foreach my $var ( @{$item->{vars}} ) {
	3493	$var = lc($var);
	3494	my $version = $rows->{$var}->{value};
	3495	PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
	3496	'on', $instance->{name});
	3497	push @versions, $version;
	3498	}
	3499	$version_for{ $instance->{id} } = join(' ', @versions);
	3500	}
	3501
	3502	return \%version_for;
	3503	}
	3504
	3505	sub get_bin_version {
526.1.2 by Daniel Nichter Update, clean up VersionCheck. Update it all tools.	3506	my (%args) = @_;
517.2.2 by Brian Fraser Update files to use the merged Pingback+VersionCheck	3507	my $item = $args{item};
	3508	my $cmd = $item->{item};
	3509	return unless $cmd;
	3510
	3511	my $sanitized_command = File::Basename::basename($cmd);
	3512	PTDEBUG && _d('cmd:', $cmd, 'sanitized:', $sanitized_command);
	3513	return if $sanitized_command !~ /\A[a-zA-Z0-9_-]+\z/;
	3514
	3515	my $output = `$sanitized_command --version 2>&1`;
	3516	PTDEBUG && _d('output:', $output);
	3517
	3518	my ($version) = $output =~ /v?([0-9]+\.[0-9]+(?:\.[\w-]+)?)/;
	3519
	3520	PTDEBUG && _d('Version for', $sanitized_command, '=', $version);
	3521	return $version;
	3522	}
	3523
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3524	sub _d {
	3525	my ($package, undef, $line) = caller 0;
	3526	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
	3527	map { defined $_ ? $_ : 'undef' }
	3528	@_;
	3529	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
	3530	}
	3531
	3532	1;
	3533	}
	3534	# ###########################################################################
522 by Daniel Nichter Rename Pingback.pm to VersionCheck.pm.	3535	# End VersionCheck package
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	3536	# ###########################################################################
	3537
	3538	# ###########################################################################
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3539	# This is a combination of modules and programs in one -- a runnable module.
	3540	# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
	3541	# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
	3542	#
	3543	# Check at the end of this package for the call to main() which actually runs
	3544	# the program.
	3545	# ###########################################################################
5 by Daniel Nichter Change tool packages from mk_ to pt_.	3546	package pt_find;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3547
	3548	use strict;
	3549	use warnings FATAL => 'all';
	3550	use English qw(-no_match_vars);
	3551
350.1.15 by Daniel Nichter Remove _d from Percona::Toolkit because I can't get it to export correctly. Put Percona::Toolkit in most tools.	3552	use Percona::Toolkit;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	3553	use constant PTDEBUG => $ENV{PTDEBUG} \|\| 0;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3554
	3555	$OUTPUT_AUTOFLUSH = 1;
	3556
	3557	# ############################################################################
	3558	# Lookup tables and global variables
	3559	# ############################################################################
	3560	my $o; # OptionParser obj
	3561	my %fmt_for; # Interpolated strings
	3562	my %time_for; # Holds time constants for mmin, mtime etc
	3563	my %connections; # Holds a list of thread IDs connected
	3564	my $server_id; # Holds the server's @@SERVER_ID
	3565	my $dbh; # This program's $dbh
	3566	my $exec_dbh; # The $dbh to use for exec and exec-plus
	3567	my $tp;
	3568
	3569	# Functions to call while evaluating tests.
	3570	my %test_for = (
	3571	autoinc => sub {
	3572	my ( $table ) = @_;
	3573	return test_number($table, 'Auto_increment', $o->get('autoinc'));
	3574	},
	3575	avgrowlen => sub {
	3576	my ( $table ) = @_;
	3577	return test_number($table, 'Avg_row_length', $o->get('avgrowlen'));
	3578	},
	3579	checksum => sub {
	3580	my ( $table ) = @_;
	3581	return test_number($table, 'Checksum', $o->get('checksum'));
	3582	},
	3583	cmin => sub {
	3584	my ( $table ) = @_;
	3585	return test_date($table, 'Create_time', 'cmin');
	3586	},
	3587	collation => sub {
	3588	my ( $table ) = @_;
	3589	return test_regex($table, 'Collation', $o->get('collation'));
	3590	},
	3591	'column-name' => sub {
	3592	my ( $table ) = @_;
	3593	my $struct = $table->{struct};
	3594	return unless $struct;
	3595	my $test = $o->get('column-name');
	3596	if ( $o->get('case-insensitive') ) {
	3597	$test = "(?i)$test";
	3598	}
	3599	foreach my $col ( @{$struct->{cols}} ) {
	3600	return 1 if $col =~ m/$test/;
	3601	}
	3602	return 0;
	3603	},
	3604	'column-type' => sub {
	3605	my ( $table ) = @_;
	3606	my $struct = $table->{struct};
	3607	return unless $struct;
	3608	my $test = lc($o->get('column-type'));
	3609	my $type_for = $struct->{type_for};
	3610	foreach my $col ( keys %$type_for ) {
	3611	return 1 if $type_for->{$col} eq $test;
	3612	}
	3613	return 0;
	3614	},
	3615	comment => sub {
	3616	my ( $table ) = @_;
	3617	return test_regex($table, 'Comment', $o->get('comment'));
3618	},
3619	createopts => sub {
3620	my ( $table ) = @_;
3621	return test_regex($table, 'Create_options', $o->get('createopts'));
3622	},
3623	ctime => sub {
3624	my ( $table ) = @_;
3625	return test_date($table, 'Create_time', 'ctime');
3626	},
3627	datafree => sub {
3628	my ( $table ) = @_;
3629	return test_number($table, 'Data_free', $o->get('datafree'));
3630	},
3631	datasize => sub {
3632	my ( $table ) = @_;
3633	return test_number($table, 'Data_length', $o->get('datasize'));
3634	},
3635	dbregex => sub {
3636	my ( $table ) = @_;
3637	return test_regex($table, 'Database', $o->get('dbregex'));
3638	},
3639	empty => sub {
3640	my ( $table ) = @_;
3641	return test_number($table, 'Rows', '0');
3642	},
3643	engine => sub {
3644	my ( $table ) = @_;
3645	return test_regex($table, 'Engine', $o->get('engine'));
3646	},
3647	function => sub {
3648	my ( $table ) = @_;
3649	return unless $table->{stored_code} && $table->{stored_code} eq 'FUNCTION';
3650	my $def = $table->{def};
3651	return unless $def;
3652	my $test = $o->get('function');
3653	if ( $o->get('case-insensitive') ) {
3654	$test = "(?i)$test";
3655	}
3656	return $def =~ m/$test/;
3657	},
3658	indexsize => sub {
3659	my ( $table ) = @_;
3660	return test_number($table, 'Index_length', $o->get('indexsize'));
3661	},
3662	kmin => sub {
3663	my ( $table ) = @_;
3664	return test_date($table, 'Check_time', 'kmin');
3665	},
3666	ktime => sub {
3667	my ( $table ) = @_;
3668	return test_date($table, 'Check_time', 'ktime');
3669	},
3670	mmin => sub {
3671	my ( $table ) = @_;
3672	return test_date($table, 'Update_time', 'mmin');
3673	},
3674	mtime => sub {
3675	my ( $table ) = @_;
3676	return test_date($table, 'Update_time', 'mtime');
3677	},
3678	'connection-id' => sub {
3679	my ( $table ) = @_;
3680	my $test = $o->get('case-insensitive') ? "(?i)".$o->get('connection-id')
3681	: $o->get('connection-id');
3682	my ( $pid ) = $table->{Name} =~ m/$test/;
3683	return $pid && !exists $connections{$pid};
3684	},
3685	procedure => sub {
3686	my ( $table ) = @_;
3687	return unless $table->{stored_code} && $table->{stored_code} eq 'PROCEDURE';
3688	my $def = $table->{def};
3689	return unless $def;
3690	my $test = $o->get('procedure');
3691	if ( $o->get('case-insensitive') ) {
3692	$test = "(?i)$test";
3693	}
3694	return $def =~ m/$test/;
3695	},
3696	rows => sub {
3697	my ( $table ) = @_;
3698	return test_number($table, 'Rows', $o->get('rows'));
3699	},
3700	rowformat => sub {
3701	my ( $table ) = @_;
3702	return test_regex($table, 'Row_format', $o->get('rowformat'));
3703	},
3704	'server-id' => sub {
3705	my ( $table ) = @_;
3706	my $test = $o->get('case-insensitive') ? "(?i)".$o->get('server-id')
3707	: $o->get('server-id');
3708	my ( $sid ) = $table->{Name} =~ m/$test/;
3709	return $sid && $sid == $server_id;
3710	},
3711	tablesize => sub {
3712	my ( $table ) = @_;
3713	return test_number($table, 'Table_length', $o->get('tablesize'));
3714	},
3715	tblregex => sub {
3716	my ( $table ) = @_;
3717	return test_regex($table, 'Name', $o->get('tblregex'));
3718	},
3719	tblversion => sub {
3720	my ( $table ) = @_;
3721	return test_number($table, 'Version', $o->get('tblversion'));
3722	},
3723	trigger => sub {
3724	my ( $table ) = @_;
3725	return unless $table->{stored_code} && $table->{stored_code} eq 'TRIGGER';
3726	my $def = $table->{def};
3727	return unless $def;
3728	my $test = $o->get('trigger');
3729	if ( $o->get('case-insensitive') ) {
3730	$test = "(?i)$test";
3731	}
3732	return $def =~ m/$test/;
3733	},
3734	'trigger-table' => sub {
3735	my ( $table ) = @_;
3736	return unless $table->{stored_code} && $table->{stored_code} eq 'TRIGGER';
3737	my $test = $o->get('trigger-table');
3738	if ( $o->get('case-insensitive') ) {
3739	$test = "(?i)$test";
3740	}
3741	return $table->{trigger_table} =~ m/$test/;
3742	},
3743	view => sub {
3744	my ( $table ) = @_;
3745	my $view = $table->{view};
3746	return unless $view;
3747	my $test = $o->get('view');
3748	if ( $o->get('case-insensitive') ) {
3749	$test = "(?i)$test";
3750	}
3751	return $view =~ m/$test/;
3752	},
3753	);
3754
3755	# Functions to call when doing actions
3756	my %action_for = (
3757	print => sub {
3758	my ( $table ) = @_;
3759	print "$table->{Database}.$table->{Name}\n";
3760	},
3761	exec => sub {
3762	my ( $table ) = @_;
3763	my $sql = sprintf($fmt_for{exec}->{str},
3764	map { defined $_ ? $_ : '' }
3765	@{$table}{@{$fmt_for{exec}->{arg_names}}});
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	3766	PTDEBUG && _d($sql);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3767	$exec_dbh->do($sql);
	3768	},
	3769	printf => sub {
	3770	my ( $table ) = @_;
	3771	printf($fmt_for{printf}->{str},
	3772	map { defined $_ ? $_ : '' }
	3773	@{$table}{@{$fmt_for{printf}->{arg_names}}});
	3774	},
	3775	);
	3776
	3777	my %arg_for = (
	3778	a => 'Auto_increment',
	3779	A => 'Avg_row_length',
	3780	c => 'Checksum',
	3781	C => 'Create_time',
	3782	D => 'Database',
	3783	d => 'Data_length',
	3784	E => 'Engine',
	3785	F => 'Data_free',
	3786	f => 'Innodb_free',
	3787	I => 'Index_length',
	3788	K => 'Check_time',
	3789	L => 'Collation',
	3790	M => 'Max_data_length',
	3791	N => 'Name',
	3792	O => 'Comment',
	3793	P => 'Create_options',
	3794	R => 'Row_format',
	3795	S => 'Rows',
	3796	T => 'Table_length',
	3797	U => 'Update_time',
	3798	V => 'Version',
	3799	);
	3800
	3801	my @table_struct_tests = qw(
	3802	column-name
	3803	column-type
	3804	view
	3805	);
	3806
	3807	my @stored_code_tests = qw(
	3808	procedure
	3809	function
	3810	trigger
	3811	);
	3812
	3813	sub main {
350.1.24 by Daniel Nichter Add $ENV{PERCONA_VERSION_CHECK}=0 to PerconaTest so tests don't version-check. Implement v-c in half the tools. Make util/update-modules clean up its temp files.	3814	local @ARGV = @_; # set global ARGV for this package
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3815
	3816	# ########################################################################
	3817	# Get configuration information.
	3818	# ########################################################################
	3819	my $q = new Quoter();
	3820	$o = new OptionParser();
	3821	$o->get_specs();
	3822	$o->get_opts();
	3823
	3824	my $dp = $o->DSNParser();
531.2.1 by Daniel Nichter Update --set-vars and ->prop() in all tools.	3825	$dp->prop('set-vars', $o->set_vars());
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3826
	3827	# Make sure OptionParser understands that these options are used.
	3828	# cmin ctime empty kmin ktime mmin mtime exec printf
	3829
	3830	# Ensure there is a capture group.
	3831	if ( $o->get('connection-id') && $o->get('connection-id') !~ m/$\\d\+$/ ) {
	3832	$o->save_error("--connection-id regex doesn't capture digits with (\\d+)");
	3833	}
	3834
	3835	# Ensure there is a capture group.
	3836	if ( $o->get('server-id') && $o->get('server-id') !~ m/$\\d\+$/ ) {
	3837	$o->save_error("--server-id regex doesn't capture digits with (\\d+)");
	3838	}
	3839
	3840	$o->usage_or_errors();
	3841
	3842	# Interpolate strings for printf and exec. At the same time discover whether
	3843	# I must use SHOW TABLE STATUS (slower than SHOW TABLES) to fetch data.
	3844	my $showstat
	3845	= grep { $o->get($_) } qw(
	3846	autoinc avgrowlen checksum cmin collation comment createopts ctime
	3847	datasize datafree empty engine indexsize kmin ktime mmin mtime rows
	3848	rowformat tablesize tblversion);
	3849	foreach my $thing (qw(exec printf)) {
	3850	next unless $o->get($thing);
	3851	my ($str, $arg_names) = interpolate($o->get($thing));
	3852	$fmt_for{$thing} = { str => $str, arg_names => $arg_names };
	3853	if ( grep { $_ !~ m/^(Database\|Name)$/ } @$arg_names ) {
	3854	$showstat = 1;
	3855	}
	3856	}
	3857
	3858	# Discover if we need to parse SHOW CREATE TABLE.
	3859	my $need_table_struct = grep { $o->got($_); } @table_struct_tests;
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	3860	PTDEBUG && _d('Need table struct:', $need_table_struct);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3861	if ( $need_table_struct ) {
	3862	$tp = new TableParser(Quoter => $q);
	3863	}
	3864
	3865	# ########################################################################
	3866	# If --pid, check it first since we'll die if it already exits.
	3867	# ########################################################################
	3868	my $daemon;
	3869	if ( $o->get('pid') ) {
	3870	# We're not daemoninzing, it just handles PID stuff. Keep $daemon
	3871	# in the the scope of main() because when it's destroyed it automatically
	3872	# removes the PID file.
	3873	$daemon = new Daemon(o=>$o);
	3874	$daemon->make_PID_file();
	3875	}
	3876
	3877	# ########################################################################
	3878	# Get ready to do the main work.
	3879	# ########################################################################
	3880
	3881	# Connect to the database.
	3882	if ( $o->get('ask-pass') ) {
	3883	$o->set('password', OptionParser::prompt_noecho("Enter password: "));
	3884	}
	3885
	3886	my $dsn = $dp->parse_options($o);
	3887	$dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1 } );
	3888	if ( $o->get('exec-dsn') ) {
	3889	my $exec_dsn = $dp->parse($o->get('exec-dsn'), $dsn);
	3890	$exec_dbh = $dp->get_dbh($dp->get_cxn_params($exec_dsn),
	3891	{ AutoCommit => 1 });
	3892	}
	3893	else {
	3894	$exec_dbh = $dbh;
	3895	}
	3896
	3897	# If no other action was given, the default action is to print.
	3898	if ( !grep { $o->get($_) } qw( exec exec-plus print printf ) ) {
	3899	$o->set('print', 1);
	3900	}
	3901
	3902	# Figure out the time referred to by date/time options.
	3903	my $basetime;
	3904	foreach my $option (
	3905	grep { defined $o->get($_) } qw(cmin ctime kmin ktime mmin mtime) )
	3906	{
	3907	# Initialize a consistent point in time.
	3908	$basetime \|\|=
	3909	$dbh->selectcol_arrayref(
	3910	"SELECT " . ($o->get('day-start') ? 'CURRENT_DATE'
	3911	: 'CURRENT_TIMESTAMP')
	3912	)->[0];
	3913
	3914	my ($val) = $o->get($option) =~ m/(\d+)/;
	3915	my $inter = $option =~ m/min/ ? 'MINUTE' : 'DAY';
	3916	my $query = "SELECT DATE_SUB('$basetime', INTERVAL $val $inter)";
	3917	$time_for{$option} = $dbh->selectcol_arrayref($query)->[0];
	3918	}
	3919
	3920	# Fetch and save a list of processes currently running.
	3921	if ( $o->get('connection-id') ) {
	3922	# Ensure I have the PROCESS privilege.
	3923	my $proc =
	3924	grep { m/ALL PRIVILEGES.?\\.\*\|PROCESS/ }
3925	@{$dbh->selectcol_arrayref('SHOW GRANTS')};
3926	if ( !$proc ) {
3927	die "--connection-id requires the PROCESS privilege for safety.\n";
3928	}
3929	}
3930
3931	($server_id) = $dbh->selectrow_array('SELECT @@SERVER_ID');
3932
3933	# Discover if we need to get stored code. Need dbh to do this.
303.2.25 by Brian Fraser Update modules & cut the VP and Mo dependency from several tools	3934	my $need_stored_code = grep { $o->got($_); } @stored_code_tests;
350.1.24 by Daniel Nichter Add $ENV{PERCONA_VERSION_CHECK}=0 to PerconaTest so tests don't version-check. Implement v-c in half the tools. Make util/update-modules clean up its temp files.	3935
	3936	# ########################################################################
	3937	# Do the version-check
	3938	# ########################################################################
526.1.1 by Daniel Nichter Change --version-check to --[no]version-check, update POD text and how version_check() is called.	3939	if ( $o->get('version-check') && (!$o->has('quiet') \|\| !$o->get('quiet')) ) {
522 by Daniel Nichter Rename Pingback.pm to VersionCheck.pm.	3940	VersionCheck::version_check(
526.1.12 by Daniel Nichter Add force => ->got('version-check') to tools.	3941	force => $o->got('version-check'),
526.1.1 by Daniel Nichter Change --version-check to --[no]version-check, update POD text and how version_check() is called.	3942	instances => [ { dbh => $dbh, dsn => $dsn } ],
390.1.1 by Brian Fraser v-c: Re-enable https by default, make --version-check take an optional protocol argument	3943	);
350.1.24 by Daniel Nichter Add $ENV{PERCONA_VERSION_CHECK}=0 to PerconaTest so tests don't version-check. Implement v-c in half the tools. Make util/update-modules clean up its temp files.	3944	}
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3945
	3946	# ########################################################################
	3947	# Go do it.
	3948	# ########################################################################
	3949	my @databases = @ARGV ? @ARGV
	3950	: $o->get('dblike') ? @{$dbh->selectcol_arrayref('SHOW DATABASES LIKE ?', {}, $o->get('dblike'))}
	3951	: @{$dbh->selectcol_arrayref('SHOW DATABASES')};
	3952
	3953	my @exec_plus;
	3954	DATABASE:
	3955	foreach my $database ( @databases ) {
	3956	next DATABASE if $database =~ m/^(?:information_schema\|lost\+found)$/mi;
	3957
	3958	my $sta = $showstat ? ' STATUS' : 'S';
	3959	my $sth = $o->get('tbllike')
	3960	? $dbh->prepare("SHOW TABLE$sta FROM `$database` LIKE ?")
	3961	: $dbh->prepare("SHOW TABLE$sta FROM `$database`");
	3962
	3963	$sth->execute($o->get('tbllike') \|\| ());
	3964	my @tables = @{$sth->fetchall_arrayref({})};
	3965
	3966	# Must re-fetch every time; there are too many ways things can go wrong
	3967	# otherwise (for example, the counter wraps over the unsigned int
	3968	# boundary).
	3969	if ( $o->get('connection-id') ) {
	3970	%connections = map { $_ => 1 }
	3971	@{$dbh->selectcol_arrayref('SHOW FULL PROCESSLIST')};
	3972	}
	3973
	3974	# Make results uniform across MySQL versions, and generate additional
	3975	# properties.
	3976	foreach my $table ( @tables ) {
	3977	if ( $showstat ) {
	3978	my ($ib_free) = $table->{Comment} && $table->{Comment} =~ m/InnoDB free: (\d+) kB/;
	3979	$table->{Engine} \|\|= $table->{Type};
	3980	$table->{Table_length} = ($table->{Index_length} \|\| 0) + ($table->{Data_length} \|\| 0);
	3981	$table->{Innodb_free} = $ib_free ? 1_024 * $ib_free : undef;
	3982	delete $table->{Type};
	3983	}
	3984	else {
	3985	my ($name) = values %$table;
	3986	$table = { Name => $name };
	3987	}
	3988	$table->{Database} = $database;
	3989
	3990	if ( $need_table_struct ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	3991	PTDEBUG && _d('Getting table struct for',
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3992	$database, '.', $table->{Name});
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	3993	my $ddl = $tp->get_create_table($dbh, $database, $table->{Name});
	3994	if ( $ddl =~ m/CREATE TABLE/ ) {
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3995	my $table_struct;
	3996	eval { $table_struct = $tp->parse($ddl) };
	3997	if ( $EVAL_ERROR ) {
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	3998	PTDEBUG && _d('Failed to parse table:', $EVAL_ERROR);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	3999	}
	4000	$table->{struct} = $table_struct;
	4001	}
94.2.184 by Baron Schwartz Fix a bazillion tests with ANSI sql_mode, and get rid of a bunch of MySQLDump usage.	4002	else {
	4003	$table->{view} = $ddl;
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4004	}
	4005	}
	4006	}
	4007
	4008	if ( $need_stored_code ) {
	4009	foreach my $type ( qw(PROCEDURE FUNCTION) ) {
	4010	my $sql = "SELECT ROUTINE_NAME AS name, "
	4011	. " ROUTINE_DEFINITION AS definition "
	4012	. " FROM INFORMATION_SCHEMA.ROUTINES "
	4013	. " WHERE ROUTINE_SCHEMA = '$database' "
	4014	. " AND ROUTINE_TYPE = '$type'";
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	4015	PTDEBUG && _d($sql);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4016	my $codes = $dbh->selectall_arrayref($sql);
	4017	foreach my $code ( @$codes ) {
	4018	push @tables, {
	4019	Database => $database,
	4020	Name => "$type $code->[0]",
	4021	stored_code => $type,
	4022	def => $code->[1],
	4023	};
	4024	}
	4025	}
	4026
	4027	my $sql = "SELECT TRIGGER_NAME AS name, "
	4028	. " ACTION_STATEMENT AS action, "
	4029	. " EVENT_OBJECT_TABLE AS `table`, "
	4030	. " EVENT_MANIPULATION AS type "
	4031	. " FROM INFORMATION_SCHEMA.TRIGGERS "
	4032	. " WHERE EVENT_OBJECT_SCHEMA = '$database'";
123 by Daniel Nichter Change MKDEBUG to PTDEBUG. Remove 1.0.2 from release notes.	4033	PTDEBUG && _d($sql);
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4034	my $trigs = $dbh->selectall_arrayref($sql);
	4035	my $codes = $dbh->selectall_arrayref($sql);
	4036	foreach my $trig ( @$trigs ) {
	4037	push @tables, {
	4038	Database => $database,
	4039	Name => "$trig->[3] TRIGGER $trig->[0] on $trig->[2]",
	4040	trigger_table => $trig->[2],
	4041	stored_code => 'TRIGGER',
	4042	def => $trig->[1],
	4043	};
	4044	}
	4045	}
	4046
	4047	# Apply the tests to find the matching tables.
	4048	@tables = grep {
	4049	my $table = $_;
	4050	my @tests = grep { $o->get($_) } keys %test_for;
	4051	if ( @tests ) {
	4052	($o->get('or') ? any($table, @tests) : all($table, @tests));
	4053	}
	4054	else {
	4055	$table; # No tests == all tables (issue 549).
	4056	}
	4057	} @tables;
	4058
	4059	# Quote database and table names if desired.
	4060	if ( $o->get('quote') ) {
	4061	foreach my $table ( @tables ) {
	4062	$table->{Database} = $q->quote($table->{Database});
	4063	$table->{Name} = $q->quote($table->{Name});
	4064	}
	4065	}
	4066
	4067	foreach my $table ( @tables ) {
	4068	my @actions = grep { $o->get($_) } keys %action_for;
	4069	foreach my $action ( @actions ) {
	4070	$action_for{$action}->($table);
	4071	}
	4072	}
	4073
	4074	push @exec_plus, @tables;
	4075	}
	4076
	4077	# Handle exec-plus.
	4078	if ( $o->get('exec-plus') ) {
	4079	my $table_list = join(', ',map {"$_->{Database}.$_->{Name}"} @exec_plus);
	4080	(my $sql = $o->get('exec-plus')) =~ s/%s/$table_list/g;
	4081	$exec_dbh->do($sql);
	4082	}
	4083
	4084	return 0;
	4085	}
	4086
	4087	# ############################################################################
	4088	# Subroutines
	4089	# ############################################################################
	4090
	4091	# One test is true
	4092	sub any {
	4093	my ( $table, @tests ) = @_;
	4094	foreach my $test ( @tests ) {
	4095	return 1 if $test_for{$test}->($table);
	4096	}
	4097	return 0;
4098	}
4099
4100	# All tests are true
4101	sub all {
4102	my ( $table, @tests ) = @_;
4103	foreach my $test ( @tests ) {
4104	return 0 unless $test_for{$test}->($table);
4105	}
4106	return 1;
4107	}
4108
4109	# Checks the given property of the given table to see if it passes the test
4110	sub test_number {
4111	my ( $table, $prop, $test ) = @_;
4112
4113	# E.g. --datasize NULL.
4114	if ( $test eq 'null' ) {
4115	return !defined $table->{$prop};
4116	}
4117
4118	my ($num) = $test =~ m/(\d+)/;
4119	return defined $table->{$prop} && (
4120	( $test =~ m/-/ && $table->{$prop} < $num )
4121	\|\| ( $test =~ m/\+/ && $table->{$prop} > $num )
4122	\|\| ( $table->{$prop} == $num ));
4123	}
4124
4125	# Checks the given property of the given table to see if it passes the test
4126	sub test_date {
4127	my ( $table, $prop, $test ) = @_;
4128	return defined $table->{$prop} && (
4129	( $o->get($test) =~ m/-/ && $table->{$prop} gt $time_for{$test} )
4130	\|\| ( $o->get($test) =~ m/\+/ && $table->{$prop} lt $time_for{$test} )
4131	\|\| ( $table->{$prop} eq $time_for{$test} ));
4132	}
4133
4134	# Checks the given property of the given table to see if it passes the test
4135	sub test_regex {
4136	my ( $table, $prop, $test ) = @_;
4137	if ( $o->get('case-insensitive') ) {
4138	$test = "(?i)$test";
4139	}
4140	return defined $table->{$prop} && $table->{$prop} =~ m/$test/;
4141	}
4142
4143	# Does string-interpolation and stuff. Returns the string and a list of the
4144	# properties that go into the resulting placeholders.
4145	sub interpolate {
4146	my ( $str ) = @_;
4147	my @arg_names;
4148
4149	# Replace % directives
4150	$str =~ s/%(.)/(exists $arg_for{$1} && push @arg_names, $arg_for{$1} ) ? '\%s' : "$1"/xge;
4151
4152	# Get Perl to interpolate escape sequences
4153	$str =~ s/(?<!\\)"/\\"/g;
4154	$str = eval qq{"$str"};
4155	return ( $str, \@arg_names );
4156	}
4157
4158	sub expand {
4159	my ( $test ) = @_;
4160	my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
4161	my ($pre, $num, $factor) = $test =~ m/([+-])?(\d+)([kMG])?/;
4162	if ( $factor ) {
4163	$num *= $factor_for{$factor};
4164	}
4165	return "$pre$num";
4166	}
4167
4168	sub _d {
4169	my ($package, undef, $line) = caller 0;
4170	@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
4171	map { defined $_ ? $_ : 'undef' }
4172	@_;
4173	print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
4174	}
4175
4176	# ############################################################################
4177	# Run the program.
4178	# ############################################################################
4179	if ( !caller ) { exit main(@ARGV); }
4180
4181	1; # Because this is a module as well as a script.
4182
4183	# ############################################################################
4184	# Documentation
4185	# ############################################################################
4186
4187	=pod
4188
4189	=head1 NAME
4190
6 by Daniel Nichter Change mk- to pt- in all tools.	4191	pt-find - Find MySQL tables and execute actions, like GNU find.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4192
	4193	=head1 SYNOPSIS
	4194
548.1.1 by Daniel Nichter Update RISKS section in all tools.	4195	Usage: pt-find [OPTIONS] [DATABASES]
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4196
6 by Daniel Nichter Change mk- to pt- in all tools.	4197	pt-find searches for MySQL tables and executes actions, like GNU find. The
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4198	default action is to print the database and table name.
	4199
	4200	Find all tables created more than a day ago, which use the MyISAM engine, and
	4201	print their names:
	4202
6 by Daniel Nichter Change mk- to pt- in all tools.	4203	pt-find --ctime +1 --engine MyISAM
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4204
435.1.1 by Daniel Nichter Remove doc example that doesn't exist.	4205	Find InnoDB tables and convert them to MyISAM:
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4206
435.1.1 by Daniel Nichter Remove doc example that doesn't exist.	4207	pt-find --engine InnoDB --exec "ALTER TABLE %D.%N ENGINE=MyISAM"
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4208
	4209	Find tables created by a process that no longer exists, following the
	4210	name_sid_pid naming convention, and remove them.
	4211
6 by Daniel Nichter Change mk- to pt- in all tools.	4212	pt-find --connection-id '\D_\d+_(\d+)$' --server-id '\D_(\d+)_\d+$' --exec-plus "DROP TABLE %s"
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4213
	4214	Find empty tables in the test and junk databases, and delete them:
	4215
6 by Daniel Nichter Change mk- to pt- in all tools.	4216	pt-find --empty junk test --exec-plus "DROP TABLE %s"
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4217
	4218	Find tables more than five gigabytes in total size:
	4219
6 by Daniel Nichter Change mk- to pt- in all tools.	4220	pt-find --tablesize +5G
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4221
	4222	Find all tables and print their total data and index size, and sort largest
	4223	tables first (sort is a different program, by the way).
	4224
6 by Daniel Nichter Change mk- to pt- in all tools.	4225	pt-find --printf "%T\t%D.%N\n" \| sort -rn
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4226
	4227	As above, but this time, insert the data back into the database for posterity:
	4228
6 by Daniel Nichter Change mk- to pt- in all tools.	4229	pt-find --noquote --exec "INSERT INTO sysdata.tblsize(db, tbl, size) VALUES('%D', '%N', %T)"
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4230
	4231	=head1 RISKS
	4232
548.1.1 by Daniel Nichter Update RISKS section in all tools.	4233	Percona Toolkit is mature, proven in the real world, and well tested,
	4234	but all database tools can pose a risk to the system and the database
	4235	server. Before using this tool, please:
	4236
	4237	=over
	4238
	4239	=item * Read the tool's documentation
	4240
	4241	=item * Review the tool's known L<"BUGS">
	4242
	4243	=item * Test the tool on a non-production server
	4244
	4245	=item * Backup your production server and verify the backups
	4246
	4247	=back
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4248
	4249	=head1 DESCRIPTION
	4250
6 by Daniel Nichter Change mk- to pt- in all tools.	4251	pt-find looks for MySQL tables that pass the tests you specify, and executes
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4252	the actions you specify. The default action is to print the database and table
	4253	name to STDOUT.
	4254
6 by Daniel Nichter Change mk- to pt- in all tools.	4255	pt-find is simpler than GNU find. It doesn't allow you to specify
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4256	complicated expressions on the command line.
	4257
6 by Daniel Nichter Change mk- to pt- in all tools.	4258	pt-find uses SHOW TABLES when possible, and SHOW TABLE STATUS when needed.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4259
	4260	=head1 OPTION TYPES
	4261
	4262	There are three types of options: normal options, which determine some behavior
	4263	or setting; tests, which determine whether a table should be included in the
6 by Daniel Nichter Change mk- to pt- in all tools.	4264	list of tables found; and actions, which do something to the tables pt-find
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4265	finds.
	4266
6 by Daniel Nichter Change mk- to pt- in all tools.	4267	pt-find uses standard Getopt::Long option parsing, so you should use double
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4268	dashes in front of long option names, unlike GNU find.
	4269
	4270	=head1 OPTIONS
	4271
	4272	This tool accepts additional command-line arguments. Refer to the
	4273	L<"SYNOPSIS"> and usage information for details.
	4274
	4275	=over
	4276
	4277	=item --ask-pass
	4278
	4279	Prompt for a password when connecting to MySQL.
	4280
	4281	=item --case-insensitive
	4282
	4283	Specifies that all regular expression searches are case-insensitive.
	4284
	4285	=item --charset
	4286
	4287	short form: -A; type: string
	4288
	4289	Default character set. If the value is utf8, sets Perl's binmode on
	4290	STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
	4291	NAMES UTF8 after connecting to MySQL. Any other value sets binmode on STDOUT
	4292	without the utf8 layer, and runs SET NAMES after connecting to MySQL.
	4293
	4294	=item --config
	4295
	4296	type: Array
	4297
	4298	Read this comma-separated list of config files; if specified, this must be the
	4299	first option on the command line.
	4300
547.4.1 by Brian Fraser Fix for 1008796: Several tools lack --database	4301	=item --database
	4302
	4303	short form: -D; type: string
	4304
	4305	Connect to this database.
	4306
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4307	=item --day-start
	4308
	4309	Measure times (for L<"--mmin">, etc) from the beginning of today rather than
	4310	from the current time.
	4311
	4312	=item --defaults-file
	4313
	4314	short form: -F; type: string
	4315
	4316	Only read mysql options from the given file. You must give an absolute
	4317	pathname.
	4318
	4319	=item --help
	4320
	4321	Show help and exit.
	4322
	4323	=item --host
	4324
	4325	short form: -h; type: string
	4326
	4327	Connect to host.
	4328
	4329	=item --or
	4330
	4331	Combine tests with OR, not AND.
	4332
	4333	By default, tests are evaluated as though there were an AND between them. This
	4334	option switches it to OR.
	4335
6 by Daniel Nichter Change mk- to pt- in all tools.	4336	Option parsing is not implemented by pt-find itself, so you cannot specify
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4337	complicated expressions with parentheses and mixtures of OR and AND.
	4338
	4339	=item --password
	4340
	4341	short form: -p; type: string
	4342
	4343	Password to use when connecting.
	4344
	4345	=item --pid
	4346
	4347	type: string
	4348
530.1.8 by Daniel Nichter Use the same blurb for --pid in all tools.	4349	Create the given PID file. The tool won't start if the PID file already
	4350	exists and the PID it contains is different than the current PID. However,
	4351	if the PID file exists and the PID it contains is no longer running, the
	4352	tool will overwrite the PID file with the current PID. The PID file is
	4353	removed automatically when the tool exits.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4354
	4355	=item --port
	4356
	4357	short form: -P; type: int
	4358
	4359	Port number to use for connection.
	4360
	4361	=item --[no]quote
	4362
	4363	default: yes
	4364
	4365	Quotes MySQL identifier names with MySQL's standard backtick character.
	4366
	4367	Quoting happens after tests are run, and before actions are run.
	4368
	4369	=item --set-vars
	4370
531.2.1 by Daniel Nichter Update --set-vars and ->prop() in all tools.	4371	type: Array
	4372
	4373	Set the MySQL variables in this comma-separated list of C<variable=value> pairs.
	4374
	4375	By default, the tool sets:
	4376
	4377	=for comment ignore-pt-internal-value
	4378	MAGIC_set_vars
	4379
	4380	wait_timeout=10000
	4381
	4382	Variables specified on the command line override these defaults. For
	4383	example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
	4384
	4385	The tool prints a warning and continues if a variable cannot be set.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4386
	4387	=item --socket
	4388
	4389	short form: -S; type: string
	4390
	4391	Socket file to use for connection.
	4392
	4393	=item --user
	4394
	4395	short form: -u; type: string
	4396
	4397	User for login if not current user.
	4398
	4399	=item --version
	4400
	4401	Show version and exit.
	4402
526.1.1 by Daniel Nichter Change --version-check to --[no]version-check, update POD text and how version_check() is called.	4403	=item --[no]version-check
	4404
	4405	default: yes
	4406
	4407	Check for the latest version of Percona Toolkit, MySQL, and other programs.
	4408
	4409	This is a standard "check for updates automatically" feature, with two
	4410	additional features. First, the tool checks the version of other programs
	4411	on the local system in addition to its own version. For example, it checks
	4412	the version of every MySQL server it connects to, Perl, and the Perl module
	4413	DBD::mysql. Second, it checks for and warns about versions with known
	4414	problems. For example, MySQL 5.5.25 had a critical bug and was re-released
	4415	as 5.5.25a.
	4416
	4417	Any updates or known problems are printed to STDOUT before the tool's normal
	4418	output. This feature should never interfere with the normal operation of the
	4419	tool.
	4420
	4421	For more information, visit L<https://www.percona.com/version-check>.
350.1.16 by Daniel Nichter Add --[no]version-check, VersionCheck, Pingback, and HTTPMicro to tools having the version check feature.	4422
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4423	=back
	4424
	4425	=head2 TESTS
	4426
	4427	Most tests check some criterion against a column of SHOW TABLE STATUS output.
	4428	Numeric arguments can be specified as +n for greater than n, -n for less than n,
	4429	and n for exactly n. All numeric options can take an optional suffix multiplier
	4430	of k, M or G (1_024, 1_048_576, and 1_073_741_824 respectively). All patterns
	4431	are Perl regular expressions (see 'man perlre') unless specified as SQL LIKE
	4432	patterns.
	4433
6 by Daniel Nichter Change mk- to pt- in all tools.	4434	Dates and times are all measured relative to the same instant, when pt-find
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4435	first asks the database server what time it is. All date and time manipulation
	4436	is done in SQL, so if you say to find tables modified 5 days ago, that
	4437	translates to SELECT DATE_SUB(CURRENT_TIMESTAMP, INTERVAL 5 DAY). If you
	4438	specify L<"--day-start">, if course it's relative to CURRENT_DATE instead.
	4439
	4440	However, table sizes and other metrics are not consistent at an instant in
	4441	time. It can take some time for MySQL to process all the SHOW queries, and
6 by Daniel Nichter Change mk- to pt- in all tools.	4442	pt-find can't do anything about that. These measurements are as of the
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4443	time they're taken.
	4444
	4445	If you need some test that's not in this list, file a bug report and I'll
6 by Daniel Nichter Change mk- to pt- in all tools.	4446	enhance pt-find for you. It's really easy.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4447
	4448	=over
	4449
	4450	=item --autoinc
	4451
	4452	type: string; group: Tests
	4453
	4454	Table's next AUTO_INCREMENT is n. This tests the Auto_increment column.
	4455
	4456	=item --avgrowlen
	4457
	4458	type: size; group: Tests
	4459
	4460	Table avg row len is n bytes. This tests the Avg_row_length column.
	4461	The specified size can be "NULL" to test where Avg_row_length IS NULL.
	4462
	4463	=item --checksum
	4464
	4465	type: string; group: Tests
	4466
	4467	Table checksum is n. This tests the Checksum column.
	4468
	4469	=item --cmin
	4470
	4471	type: size; group: Tests
	4472
	4473	Table was created n minutes ago. This tests the Create_time column.
	4474
	4475	=item --collation
	4476
	4477	type: string; group: Tests
	4478
	4479	Table collation matches pattern. This tests the Collation column.
	4480
	4481	=item --column-name
	4482
	4483	type: string; group: Tests
	4484
	4485	A column name in the table matches pattern.
	4486
	4487	=item --column-type
	4488
	4489	type: string; group: Tests
	4490
	4491	A column in the table matches this type (case-insensitive).
	4492
	4493	Examples of types are: varchar, char, int, smallint, bigint, decimal, year,
	4494	timestamp, text, enum.
	4495
	4496	=item --comment
	4497
	4498	type: string; group: Tests
	4499
	4500	Table comment matches pattern. This tests the Comment column.
	4501
	4502	=item --connection-id
	4503
	4504	type: string; group: Tests
	4505
	4506	Table name has nonexistent MySQL connection ID. This tests the table name for
	4507	a pattern. The argument to this test must be a Perl regular expression that
	4508	captures digits like this: (\d+). If the table name matches the pattern,
	4509	these captured digits are taken to be the MySQL connection ID of some process.
	4510	If the connection doesn't exist according to SHOW FULL PROCESSLIST, the test
6 by Daniel Nichter Change mk- to pt- in all tools.	4511	returns true. If the connection ID is greater than pt-find's own
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4512	connection ID, the test returns false for safety.
	4513
	4514	Why would you want to do this? If you use MySQL statement-based replication,
	4515	you probably know the trouble temporary tables can cause. You might choose to
	4516	work around this by creating real tables with unique names, instead of
	4517	temporary tables. One way to do this is to append your connection ID to the
	4518	end of the table, thusly: scratch_table_12345. This assures the table name is
	4519	unique and lets you have a way to find which connection it was associated
	4520	with. And perhaps most importantly, if the connection no longer exists, you
	4521	can assume the connection died without cleaning up its tables, and this table
	4522	is a candidate for removal.
	4523
	4524	This is how I manage scratch tables, and that's why I included this test in
6 by Daniel Nichter Change mk- to pt- in all tools.	4525	pt-find.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4526
	4527	The argument I use to L<"--connection-id"> is "\D_(\d+)$". That finds tables
	4528	with a series of numbers at the end, preceded by an underscore and some
	4529	non-number character (the latter criterion prevents me from examining tables
	4530	with a date at the end, which people tend to do: baron_scratch_2007_05_07 for
	4531	example). It's better to keep the scratch tables separate of course.
	4532
6 by Daniel Nichter Change mk- to pt- in all tools.	4533	If you do this, make sure the user pt-find runs as has the PROCESS privilege!
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4534	Otherwise it will only see connections from the same user, and might think some
6 by Daniel Nichter Change mk- to pt- in all tools.	4535	tables are ready to remove when they're still in use. For safety, pt-find
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4536	checks this for you.
	4537
	4538	See also L<"--server-id">.
	4539
	4540	=item --createopts
	4541
	4542	type: string; group: Tests
	4543
	4544	Table create option matches pattern. This tests the Create_options column.
	4545
	4546	=item --ctime
	4547
	4548	type: size; group: Tests
	4549
	4550	Table was created n days ago. This tests the Create_time column.
	4551
	4552	=item --datafree
	4553
	4554	type: size; group: Tests
	4555
	4556	Table has n bytes of free space. This tests the Data_free column.
	4557	The specified size can be "NULL" to test where Data_free IS NULL.
	4558
	4559	=item --datasize
	4560
	4561	type: size; group: Tests
	4562
	4563	Table data uses n bytes of space. This tests the Data_length column.
	4564	The specified size can be "NULL" to test where Data_length IS NULL.
	4565
	4566	=item --dblike
	4567
	4568	type: string; group: Tests
	4569
	4570	Database name matches SQL LIKE pattern.
	4571
	4572	=item --dbregex
	4573
	4574	type: string; group: Tests
	4575
	4576	Database name matches this pattern.
	4577
	4578	=item --empty
	4579
	4580	group: Tests
	4581
	4582	Table has no rows. This tests the Rows column.
	4583
	4584	=item --engine
	4585
	4586	type: string; group: Tests
	4587
	4588	Table storage engine matches this pattern. This tests the Engine column, or in
	4589	earlier versions of MySQL, the Type column.
	4590
	4591	=item --function
	4592
	4593	type: string; group: Tests
	4594
	4595	Function definition matches pattern.
	4596
	4597	=item --indexsize
	4598
	4599	type: size; group: Tests
4600
4601	Table indexes use n bytes of space. This tests the Index_length column.
4602	The specified size can be "NULL" to test where Index_length IS NULL.
4603
4604	=item --kmin
4605
4606	type: size; group: Tests
4607
4608	Table was checked n minutes ago. This tests the Check_time column.
4609
4610	=item --ktime
4611
4612	type: size; group: Tests
4613
4614	Table was checked n days ago. This tests the Check_time column.
4615
4616	=item --mmin
4617
4618	type: size; group: Tests
4619
4620	Table was last modified n minutes ago. This tests the Update_time column.
4621
4622	=item --mtime
4623
4624	type: size; group: Tests
4625
4626	Table was last modified n days ago. This tests the Update_time column.
4627
4628	=item --procedure
4629
4630	type: string; group: Tests
4631
4632	Procedure definition matches pattern.
4633
4634	=item --rowformat
4635
4636	type: string; group: Tests
4637
4638	Table row format matches pattern. This tests the Row_format column.
4639
4640	=item --rows
4641
4642	type: size; group: Tests
4643
4644	Table has n rows. This tests the Rows column.
4645	The specified size can be "NULL" to test where Rows IS NULL.
4646
4647	=item --server-id
4648
4649	type: string; group: Tests
4650
4651	Table name contains the server ID. If you create temporary tables with the
4652	naming convention explained in L<"--connection-id">, but also add the server ID of the
4653	server on which the tables are created, then you can use this pattern match to
4654	ensure tables are dropped only on the server they're created on. This prevents
4655	a table from being accidentally dropped on a slave while it's in use (provided
4656	that your server IDs are all unique, which they should be for replication to
4657	work).
4658
4659	For example, on the master (server ID 22) you create a table called
4660	scratch_table_22_12345. If you see this table on the slave (server ID 23), you
4661	might think it can be dropped safely if there's no such connection 12345. But
4662	if you also force the name to match the server ID with C<--server-id '\D_(\d+)_\d+$'>,
4663	the table won't be dropped on the slave.
4664
4665	=item --tablesize
4666
4667	type: size; group: Tests
4668
4669	Table uses n bytes of space. This tests the sum of the Data_length and
4670	Index_length columns.
4671
4672	=item --tbllike
4673
4674	type: string; group: Tests
4675
4676	Table name matches SQL LIKE pattern.
4677
4678	=item --tblregex
4679
4680	type: string; group: Tests
4681
4682	Table name matches this pattern.
4683
4684	=item --tblversion
4685
4686	type: size; group: Tests
4687
4688	Table version is n. This tests the Version column.
4689
4690	=item --trigger
4691
4692	type: string; group: Tests
4693
4694	Trigger action statement matches pattern.
4695
4696	=item --trigger-table
4697
4698	type: string; group: Tests
4699
4700	L<"--trigger"> is defined on table matching pattern.
4701
4702	=item --view
4703
4704	type: string; group: Tests
4705
4706	CREATE VIEW matches this pattern.
4707
4708	=back
4709
4710	=head2 ACTIONS
4711
4712	The L<"--exec-plus"> action happens after everything else, but otherwise actions
4713	happen in an indeterminate order. If you need determinism, file a bug report
4714	and I'll add this feature.
4715
4716	=over
4717
4718	=item --exec
4719
4720	type: string; group: Actions
4721
4722	Execute this SQL with each item found. The SQL can contain escapes and
4723	formatting directives (see L<"--printf">).
4724
4725	=item --exec-dsn
4726
4727	type: string; group: Actions
4728
4729	Specify a DSN in key-value format to use when executing SQL with L<"--exec"> and
4730	L<"--exec-plus">. Any values not specified are inherited from command-line
4731	arguments.
4732
4733	=item --exec-plus
4734
4735	type: string; group: Actions
4736
4737	Execute this SQL with all items at once. This option is unlike L<"--exec">. There
4738	are no escaping or formatting directives; there is only one special placeholder
4739	for the list of database and table names, %s. The list of tables found will be
4740	joined together with commas and substituted wherever you place %s.
4741
4742	You might use this, for example, to drop all the tables you found:
4743
4744	DROP TABLE %s
4745
4746	This is sort of like GNU find's "-exec command {} +" syntax. Only it's not
4747	totally cryptic. And it doesn't require me to write a command-line parser.
4748
4749	=item --print
4750
4751	group: Actions
4752
4753	Print the database and table name, followed by a newline. This is the default
4754	action if no other action is specified.
4755
4756	=item --printf
4757
4758	type: string; group: Actions
4759
4760	Print format on the standard output, interpreting '\' escapes and '%'
4761	directives. Escapes are backslashed characters, like \n and \t. Perl
4762	interprets these, so you can use any escapes Perl knows about. Directives are
4763	replaced by %s, and as of this writing, you can't add any special formatting
4764	instructions, like field widths or alignment (though I'm musing over ways to do
4765	that).
4766
4767	Here is a list of the directives. Note that most of them simply come from
4768	columns of SHOW TABLE STATUS. If the column is NULL or doesn't exist, you get
4769	an empty string in the output. A % character followed by any character not in
4770	the following list is discarded (but the other character is printed).
4771
4772	CHAR DATA SOURCE NOTES
4773	---- ------------------ ------------------------------------------
4774	a Auto_increment
4775	A Avg_row_length
4776	c Checksum
4777	C Create_time
4778	D Database The database name in which the table lives
4779	d Data_length
4780	E Engine In older versions of MySQL, this is Type
4781	F Data_free
4782	f Innodb_free Parsed from the Comment field
4783	I Index_length
4784	K Check_time
4785	L Collation
4786	M Max_data_length
4787	N Name
4788	O Comment
4789	P Create_options
4790	R Row_format
4791	S Rows
4792	T Table_length Data_length+Index_length
4793	U Update_time
4794	V Version
4795
4796	=back
4797
4798	=head1 DSN OPTIONS
4799
4800	These DSN options are used to create a DSN. Each option is given like
4801	C<option=value>. The options are case-sensitive, so P and p are not the
4802	same option. There cannot be whitespace before or after the C<=> and
4803	if the value contains whitespace it must be quoted. DSN options are
20 by Daniel Nichter Finish re-branding tools. Remove pt-schema-advisor.	4804	comma-separated. See the L<percona-toolkit> manpage for full details.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4805
	4806	=over
	4807
	4808	=item * A
	4809
	4810	dsn: charset; copy: yes
	4811
	4812	Default character set.
	4813
	4814	=item * D
	4815
	4816	dsn: database; copy: yes
	4817
	4818	Default database.
	4819
	4820	=item * F
	4821
	4822	dsn: mysql_read_default_file; copy: yes
	4823
	4824	Only read default options from the given file
	4825
	4826	=item * h
	4827
	4828	dsn: host; copy: yes
	4829
	4830	Connect to host.
	4831
	4832	=item * p
	4833
	4834	dsn: password; copy: yes
	4835
	4836	Password to use when connecting.
	4837
	4838	=item * P
	4839
	4840	dsn: port; copy: yes
	4841
	4842	Port number to use for connection.
	4843
	4844	=item * S
	4845
	4846	dsn: mysql_socket; copy: yes
	4847
	4848	Socket file to use for connection.
	4849
	4850	=item * u
	4851
	4852	dsn: user; copy: yes
	4853
	4854	User for login if not current user.
	4855
	4856	=back
	4857
	4858	=head1 ENVIRONMENT
	4859
13 by Daniel Nichter Re-brand standard POD sections (DOWNLOADING, ENVIRONMENT, etc). Change ABOUT MAATKIT to ABOUT PERCONA TOOLKIT.	4860	The environment variable C<PTDEBUG> enables verbose debugging output to STDERR.
	4861	To enable debugging and capture all output to a file, run the tool like:
	4862
14 by Daniel Nichter Replace $TOOL with tool name.	4863	PTDEBUG=1 pt-find ... > FILE 2>&1
13 by Daniel Nichter Re-brand standard POD sections (DOWNLOADING, ENVIRONMENT, etc). Change ABOUT MAATKIT to ABOUT PERCONA TOOLKIT.	4864
	4865	Be careful: debugging output is voluminous and can generate several megabytes
	4866	of output.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4867
	4868	=head1 SYSTEM REQUIREMENTS
	4869
13 by Daniel Nichter Re-brand standard POD sections (DOWNLOADING, ENVIRONMENT, etc). Change ABOUT MAATKIT to ABOUT PERCONA TOOLKIT.	4870	You need Perl, DBI, DBD::mysql, and some core packages that ought to be
	4871	installed in any reasonably new version of Perl.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4872
	4873	=head1 BUGS
	4874
14 by Daniel Nichter Replace $TOOL with tool name.	4875	For a list of known bugs, see L<http://www.percona.com/bugs/pt-find>.
13 by Daniel Nichter Re-brand standard POD sections (DOWNLOADING, ENVIRONMENT, etc). Change ABOUT MAATKIT to ABOUT PERCONA TOOLKIT.	4876
	4877	Please report bugs at L<https://bugs.launchpad.net/percona-toolkit>.
	4878	Include the following information in your bug report:
	4879
	4880	=over
	4881
	4882	=item * Complete command-line used to run the tool
	4883
	4884	=item * Tool L<"--version">
	4885
	4886	=item * MySQL version of all servers involved
	4887
	4888	=item * Output from the tool including STDERR
	4889
	4890	=item * Input files (log/dump/config files, etc.)
	4891
	4892	=back
	4893
	4894	If possible, include debugging output by running the tool with C<PTDEBUG>;
	4895	see L<"ENVIRONMENT">.
	4896
59 by Daniel Add RISKS section to Bash tools. Re-order all tools' DOWNLOADING section. Remove some unused options.	4897	=head1 DOWNLOADING
	4898
	4899	Visit L<http://www.percona.com/software/percona-toolkit/> to download the
	4900	latest release of Percona Toolkit. Or, get the latest release from the
	4901	command line:
	4902
	4903	wget percona.com/get/percona-toolkit.tar.gz
	4904
	4905	wget percona.com/get/percona-toolkit.rpm
	4906
	4907	wget percona.com/get/percona-toolkit.deb
	4908
	4909	You can also get individual tools from the latest release:
	4910
	4911	wget percona.com/get/TOOL
	4912
	4913	Replace C<TOOL> with the name of any tool.
	4914
13 by Daniel Nichter Re-brand standard POD sections (DOWNLOADING, ENVIRONMENT, etc). Change ABOUT MAATKIT to ABOUT PERCONA TOOLKIT.	4915	=head1 AUTHORS
	4916
	4917	Baron Schwartz
	4918
	4919	=head1 ABOUT PERCONA TOOLKIT
	4920
	4921	This tool is part of Percona Toolkit, a collection of advanced command-line
548.1.2 by Daniel Nichter Update the ABOUT PERCONA TOOLKIT secction in all tools.	4922	tools for MySQL developed by Percona. Percona Toolkit was forked from two
	4923	projects in June, 2011: Maatkit and Aspersa. Those projects were created by
	4924	Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
	4925	L<http://www.percona.com/software/> to learn about other free, open-source
	4926	software from Percona.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4927
12 by Daniel Nichter Remove duplicate copyright notices. Add POD and copyright for Aspersa tools. Fix checking for "pt-pmp" instead of "pmp", etc.	4928	=head1 COPYRIGHT, LICENSE, AND WARRANTY
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4929
503.6.1 by Daniel Nichter s/Percona Inc/Percona Ireland Ltd/g	4930	This program is copyright 2011-2013 Percona Ireland Ltd,
	4931	2007-2011 Baron Schwartz.
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4932
	4933	THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
	4934	WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
	4935	MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
	4936
	4937	This program is free software; you can redistribute it and/or modify it under
	4938	the terms of the GNU General Public License as published by the Free Software
	4939	Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
	4940	systems, you can issue `man perlgpl' or `man perlartistic' to read these
	4941	licenses.
	4942
	4943	You should have received a copy of the GNU General Public License along with
	4944	this program; if not, write to the Free Software Foundation, Inc., 59 Temple
	4945	Place, Suite 330, Boston, MA 02111-1307 USA.
	4946
	4947	=head1 VERSION
	4948
580.1.3 by Brian Fraser Build percona-toolkit-2.2.2	4949	pt-find 2.2.2
3 by Daniel Nichter Add forked Maatkit tools in bin/ and their tests in t/.	4950
	4951	=cut