percona-toolkit-2.2.16/ 0000755 0001750 0001750 00000000000 12617202747 014612 5 ustar vagrant vagrant percona-toolkit-2.2.16/MANIFEST 0000644 0001750 0001750 00000001226 12617202747 015744 0 ustar vagrant vagrant Changelog
COPYING
INSTALL
Makefile.PL
MANIFEST
README
bin/pt-align
bin/pt-archiver
bin/pt-config-diff
bin/pt-deadlock-logger
bin/pt-diskstats
bin/pt-duplicate-key-checker
bin/pt-fifo-split
bin/pt-find
bin/pt-fingerprint
bin/pt-fk-error-logger
bin/pt-heartbeat
bin/pt-index-usage
bin/pt-ioprofile
bin/pt-kill
bin/pt-mext
bin/pt-mysql-summary
bin/pt-online-schema-change
bin/pt-pmp
bin/pt-query-digest
bin/pt-show-grants
bin/pt-sift
bin/pt-slave-delay
bin/pt-slave-find
bin/pt-slave-restart
bin/pt-stalk
bin/pt-summary
bin/pt-table-checksum
bin/pt-table-sync
bin/pt-table-usage
bin/pt-upgrade
bin/pt-variable-advisor
bin/pt-visual-explain
docs/percona-toolkit.pod
percona-toolkit-2.2.16/docs/ 0000755 0001750 0001750 00000000000 12617202747 015542 5 ustar vagrant vagrant percona-toolkit-2.2.16/docs/percona-toolkit.pod 0000644 0001750 0001750 00000036306 12617202747 021370 0 ustar vagrant vagrant =pod
=head1 NAME
percona-toolkit - Advanced command-line tools for MySQL
=head1 DESCRIPTION
Percona Toolkit is a collection of advanced command-line tools used by
Percona (L side-by-side.
=item pt-mysql-summary
Summarize MySQL information nicely.
=item pt-online-schema-change
ALTER tables without locking them.
=item pt-pmp
Aggregate GDB stack traces for a selected program.
=item pt-query-digest
Analyze MySQL queries from logs, processlist, and tcpdump.
=item pt-show-grants
Canonicalize and print MySQL grants so you can effectively replicate, compare and version-control them.
=item pt-sift
Browses files created by pt-stalk.
=item pt-slave-delay
Make a MySQL slave server lag behind its master.
=item pt-slave-find
Find and print replication hierarchy tree of MySQL slaves.
=item pt-slave-restart
Watch and restart MySQL replication after errors.
=item pt-stalk
Collect forensic data about MySQL when problems occur.
=item pt-summary
Summarize system information nicely.
=item pt-table-checksum
Verify MySQL replication integrity.
=item pt-table-sync
Synchronize MySQL table data efficiently.
=item pt-table-usage
Analyze how queries use tables.
=item pt-upgrade
Verify that query results are identical on different servers.
=item pt-variable-advisor
Analyze MySQL variables and advise on possible problems.
=item pt-visual-explain
Format EXPLAIN output as a tree.
=back
For more free, open-source software developed Percona, visit
L, C, etc.) as well as
these special types:
=over
=item time
Time values are seconds by default. For example, C<--run-time 60> means
60 seconds. Time values support an optional suffix: s (seconds),
m (minutes), h (hours), d (days). C<--run-time 1m> means 1 minute
(the same as 60 seconds).
=item size
Size values are bytes by default. For example, C<--disk-space-free 1024>
means 1 Kibibyte. Size values support an optional suffix: k (Kibibyte),
M (Mebibyte), G (Gibibyte).
=item DSN
See L<"DSN (DATA SOURCE NAME) SPECIFICATIONS">.
=item Hash, hash, Array, array
Hash, hash, Array, and array values are comma-separated lists of values.
For example, C<--ignore-tables foo,bar> ignores tables C and C.
=back
=head1 CONFIGURATION FILES
Percona Toolkit tools can read options from configuration files. The
configuration file syntax is simple and direct, and bears some resemblances
to the MySQL command-line client tools. The configuration files all follow
the same conventions.
Internally, what actually happens is that the lines are read from the file and
then added as command-line options and arguments to the tool, so just
think of the configuration files as a way to write your command lines.
=head2 SYNTAX
The syntax of the configuration files is as follows:
=over
=item *
Whitespace followed by a hash sign (#) signifies that the rest of the line is a
comment. This is deleted. For example:
=item *
Whitespace is stripped from the beginning and end of all lines.
=item *
Empty lines are ignored.
=item *
Each line is permitted to be in either of the following formats:
option
option=value
Do not prefix the option with C<-->. Do not quote the values, even if
it has spaces; value are literal. Whitespace around the equals sign is
deleted during processing.
=item *
Only long options are recognized.
=item *
A line containing only two hyphens signals the end of option parsing. Any
further lines are interpreted as additional arguments (not options) to the
program.
=back
=head2 EXAMPLE
This config file for pt-stalk,
# Config for pt-stalk
variable=Threads_connected
cycles=2 # trigger if problem seen twice in a row
--
--user daniel
is equivalent to this command line:
pt-stalk --variable Threads_connected --cycles 2 -- --user daniel
Options after C<--> are passed literally to mysql and mysqladmin.
=head2 READ ORDER
The tools read several configuration files in order:
=over
=item 1.
The global Percona Toolkit configuration file,
F. All tools read this file,
so you should only add options to it that you want to apply to all tools.
=item 2.
The global tool-specific configuration file, F,
where C is a tool name like C. This file is named
after the specific tool you're using, so you can add options that apply
only to that tool.
=item 3.
The user's own Percona Toolkit configuration file,
F<$HOME/.percona-toolkit.conf>. All tools read this file, so you should only
add options to it that you want to apply to all tools.
=item 4.
The user's tool-specific configuration file, F<$HOME/.TOOL.conf>,
where C is a tool name like C. This file is named
after the specific tool you're using, so you can add options that apply
only to that tool.
=back
=head2 SPECIFYING
There is a special C<--config> option, which lets you specify which
configuration files Percona Toolkit should read. You specify a
comma-separated list of files. However, its behavior is not like other
command-line options. It must be given B on the command line,
before any other options. If you try to specify it anywhere else, it will
cause an error. Also, you cannot specify C<--config=/path/to/file>;
you must specify the option and the path to the file separated by whitespace
I between them, like:
--config /path/to/file
If you don't want any configuration files at all, specify C<--config ''> to
provide an empty list of files.
=head1 DSN (DATA SOURCE NAME) SPECIFICATIONS
Percona Toolkit tools use DSNs to specify how to create a DBD connection to
a MySQL server. A DSN is a comma-separated string of C parts, like:
h=host1,P=3306,u=bob
The standard key parts are shown below, but some tools add additional key
parts. See each tool's documentation for details.
Some tools do not use DSNs but still connect to MySQL using options like
C<--host>, C<--user>, and C<--password>. Such tools uses these options to
create a DSN automatically, behind the scenes.
Other tools uses both DSNs and options like the ones above. The options
provide defaults for all DSNs that do not specify the option's corresponding
key part. For example, if DSN C and option C<--port=12345> are
specified, then the tool automatically adds C to DSN.
=head2 ESCAPING VALUES
DSNs are usually specified on the command line, so shell quoting and escaping
must be taken into account. Special characters, like asterisk (C<*>), need
to be quoted and/or escaped properly to be passed as literal characters in
DSN values.
Since DSN parts are separated by commas, literal commas in DSN values must
be escaped with a single backslash (C<\>). And since a backslash is
the escape character for most shells, two backslashes are required to pass
a literal backslash. For example, if the username is literally C,
it must be specified as C on most shells. This applies to DSNs
and DSN-related options like C<--user>.
=head2 KEY PARTS
Many of the tools add more parts to DSNs for special purposes, and sometimes
override parts to make them do something slightly different. However, all the
tools support at least the following:
=over
=item A
Default character set for the connection (C).
Enables character set settings in Perl and MySQL. If the value is C,
sets Perl's binmode on STDOUT to utf8, passes the C option
to DBD::mysql, and runs C after connecting to MySQL. Other
values set binmode on STDOUT without the utf8 layer and run C after
connecting to MySQL.
Unfortunately, there is no way from within Perl itself to specify the client
library's character set. C only affects the server; if the client
library's settings don't match, there could be problems. You can use the
defaults file to specify the client library's character set, however. See the
description of the F part below.
=item D
Default database to use when connecting. Tools may C a different
databases while running.
=item F
Defaults file for the MySQL client library (the C client library used by
DBD::mysql, I). All tools all read the
C<[client]> section within the defaults file. If you omit this, the standard
defaults files will be read in the usual order. "Standard" varies from system
to system, because the filenames to read are compiled into the client library.
On Debian systems, for example, it's usually C then
C<~/.my.cnf>. If you place the following in C<~/.my.cnf>, you won't have
to specify your MySQL username and password on the command line:
[client]
user=your_user_name
pass=secret
Omitting the F part is usually the right thing to do. As long as you have
configured your C<~/.my.cnf> correctly, that will result in tools connecting
automatically without needing a username or password.
You can also specify a default character set in the defaults file. Unlike the
L<"A"> part described above, this will actually instruct the client library
(DBD::mysql) to change the character set it uses internally, which cannot be
accomplished any other way.
=item h
MySQL hostname or IP address to connect to.
=item L
Explicitly enable LOAD DATA LOCAL INFILE.
For some reason, some vendors compile libmysql without the
--enable-local-infile option, which disables the statement. This can
lead to weird situations, like the server allowing LOCAL INFILE, but
the client throwing exceptions if it's used.
However, as long as the server allows LOAD DATA, clients can easily
re-enable it; see L
and L.
This option does exactly that.
=item p
MySQL password to use when connecting.
=item P
Port number to use for the connection. Note that the usual special-case
behaviors apply: if you specify C as your hostname on Unix systems,
the connection actually uses a socket file, not a TCP/IP connection, and thus
ignores the port.
=item S
MySQL socket file to use for the connection (on Unix systems).
=item u
MySQL username to use when connecting, if not current system user.
=back
=head2 BAREWORD
Many of the tools will let you specify a DSN as a single word, without any
C syntax. This is called a 'bareword'. How this is handled is
tool-specific, but it is usually interpreted as the L<"h"> part. The tool's
C<--help> output will tell you the behavior for that tool.
=head2 PROPAGATION
Many tools will let you propagate values from one DSN to the next, so you don't
have to specify all the parts for each DSN. For example, if you want to specify
a username and password for each DSN, you can connect to three hosts as follows:
h=host1,u=fred,p=wilma host2 host3
This is tool-specific.
=head1 ENVIRONMENT
The environment variable C enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-table-checksum ... > FILE 2>&1
Be careful: debugging output is voluminous and can generate several megabytes
of output.
=head1 SYSTEM REQUIREMENTS
Most tools require:
=over
=item * Perl v5.8 or newer
=item * Bash v3 or newer
=item * Core Perl modules like Time::HiRes
=back
Tools that connect to MySQL require:
=over
=item * Perl modules DBI and DBD::mysql
=item * MySQL 5.0 or newer
=back
Percona Toolkit officially supports and is tested on many popular Linux
distributions and MySQL 5.0 through 5.6; see http://goo.gl/srHm7 for the
list of supported platforms and versions.
=head1 BUGS
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool C<--version>
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 AUTHORS
=over
=item Baron Schwartz
Baron created Maatkit, from which Percona Toolkit was forked. Many of
the tools and modules were originally written by Baron.
=item Daniel Nichter
Daniel has been the project's lead developer since 2008. He is employed
by Percona.
=item Frank Cizmich
Frank is a full-time Percona Toolkit developer employed by Percona.
=item Others
Many people have contributed code over the years. See each tool's
"AUTHORS" section for details.
=back
=head1 COPYRIGHT, LICENSE, AND WARRANTY
Percona Toolkit is copyright 2011-2015 Percona LLC and/or its affiliates, et al.
See each program's documentation for complete copyright notices.
THIS PROGRAM IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED
WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
This program is free software; you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation, version 2; OR the Perl Artistic License. On UNIX and similar
systems, you can issue `man perlgpl' or `man perlartistic' to read these
licenses.
You should have received a copy of the GNU General Public License along with
this program; if not, write to the Free Software Foundation, Inc., 59 Temple
Place, Suite 330, Boston, MA 02111-1307 USA.
=head1 VERSION
Percona Toolkit v2.2.16 released 2015-11-06
=cut
percona-toolkit-2.2.16/INSTALL 0000644 0001750 0001750 00000002767 12617202747 015657 0 ustar vagrant vagrant Installing Percona Toolkit
==========================
System Requirements
-------------------
Most tools require:
* Perl v5.8 or newer
* Bash v3 or newer
* Core Perl modules like Time::HiRes
Tools that connect to MySQL require:
* Perl modules DBI and DBD::mysql
* MySQL 5.0 or newer
Percona Toolkit is only tested on UNIX systems, primarily Debian and
Red Hat derivatives; other operating systems are not supported.
Tools that connect to MySQL may work with MySQL v4.1, but this is not
test or supported.
Quick Install
-------------
perl Makefile.PL
make
make test
make install
Detailed Install
----------------
Extract the tarball and cd to the resulting directory:
tar zxvf percona-toolkit-.tar.gz
cd percona-toolkit-
Generate the Makefile, which will check Perl module dependencies and
so forth:
perl Makefile.PL
Build the tools' man pages and prep for test and install:
make
Test that the tools can run:
make test
All tests should pass. If not, then your system may be missing a Perl module
required by a tool. The tests are not comprehensive; they only test that the
tools can be executed by Perl and Bash.
Finally, install all tools and their man pages:
make install
On most systems, the tools are installed in /usr/local/bin.
Installation Options
--------------------
To install to a directory other than your system's default, such as your
home directory, generate the Makefile with a prefix:
perl Makefile.PL PREFIX=${HOME}
percona-toolkit-2.2.16/lib/ 0000755 0001750 0001750 00000000000 12617202747 015360 5 ustar vagrant vagrant percona-toolkit-2.2.16/Changelog 0000644 0001750 0001750 00000110542 12617202747 016427 0 ustar vagrant vagrant Changelog for Percona Toolkit
v2.2.16 released 2015-11-09
* Fixed bug 1452895: pt-archiver dies with "MySQL server has gone away" when innodb_kill_idle_transaction set to low value and bulk insert/delete process takes too long time
* Fixed bug 1488685: pt-kill option --filter does not work
* Feature 1402051: pt-online-schema-change should reconnect to slaves
* Fixed bug 1491261: pt-online-schema-change, MySQL 5.6, and InnoDB optimizer stats can cause downtime
* Fixed bug 1494082: pt-stalk find -warn option is not portable
* Feature 1389041: Document that pt-table-checksum has high likelihood to skip a table when row count is around chunk-size * chunk-size-limit
v2.2.15 released 2015-08-28
* Fixed bug 1056507: pt-archiver checked lag too frequently
* Fixed bug 1443763: pt-archiver clarified function of --check-interval [DOC]
* Feature 1452911: pt-archiver now accepts checking lag on multiple slaves
* Feature 1413137: pt-archiver now checks for PXC flow control via --max-flow-ctl option
* Fixed bug 1452914: pt-archiver options --no-delete and --purge were not mutually exclusive
* Fixed bug 1449226: pt-archiver mysql timed out when innodb_kill_idle_transaction set to low value and check-slave-lag used
* Fixed bug 1462904: pt-duplicate-key-checker doesn't support triple quote in column name
* Feature 1470127: pt-kill enable support for RDS
* Fixed bug 1455486: pt-mysql-summary lacked an --ask-pass option
* Feature 1413140: pt-online-schema-change added --sleep option
* Fixed bug 1446928: pt-online-schema-change core dump on erroneous alter directive
* Feature 1413101: pt-online-schema-change now checks for PXC flow control via --max-flow-ctl option
* Fixed bug 1450499: pt-online-schema-change unstable signal handling
* Feature 1215587: pt-online-schema-change now controls constraint name length
* Fixed bug 1441928: pt-online-schema-change --chunk-size-limit=0 inhibited checksumming of single nibble tables
* Fixed bug 1457573: pt-sift failed when fetching missing tools
* Feature 1488600: pt-stalk monitors tokudb status
* Fixed bug 1042727: pt-table-checksum doesn't reconnect to slaves when timed out on very long lags
* Fixed bug 1277049: passsword parameter must escape commas - all tools [DOC]
* Fixed bug BLD-271: changes needed to build packages from git tree
* Fixed bug PT-21 : write-user-docs script stopped working after switching to github
* Fixed bug 1488611: testing bugs related to newer perl versions
v2.2.14 released 2015-04-14
* Fixed bug 1402730: pt-duplicate-key-checker seems useless with MySQL 5.6
* Fixed bug 1415646: pt-duplicate-key-checker documentation does not explain how Size Duplicate Indexes is calculated
* Fixed bug 1406390: pt-heartbeat crashes with sleep argument error
* Fixed bug 1368244: pt-online-schema-change --alter-foreign-keys-method=drop-swap is not atomic
* FIxed bug 1417864: pt-online-schema-change documentation, the interpretation of --tries create_triggers:5:0.5,drop_triggers:5:0.5 is wrong
* Fixed bug 1404313: pt-query-digest: specifying a file that doesn't exist as log causes the tool to wait for STDIN instead of giving an error
* Feature 1418446: pt-slave-find resolve IP addresses option
* Fixed bug 1417558: pt-stalk with --collect-strace output doesn't go to an YYYY_MM_DD_HH_mm_ss-strace file
* Fixed bug 1425478: pt-stalk removes non-empty files that start with empty line
* Fixed bug 925781: pt-table-checksum checksum error when default-character-set = utf8
* Fixed bug 1381280: pt-table-checksum fails on BINARY field in PK
* Feature 1439842: pt-table-sync lacks --ignore-tables-regex option
* Fixed bug 1401399: pt-table-sync fails to close one db handle
* Fixed bug 1442277: pt-table-sync-ignores system databases but doc doesn't clarify this
* Fixed bug 1421781: pt-upgrade fails on SELECT ... INTO queries
* Fixed bug 1421405: pt-upgrade fails to aggregate queries based on fingerprint
* Fixed bug 1439348: pt-upgrade erroneously reports number of diffs
* Fixed bug 1421025: rpm missing dependency on perl-TermReadKey for --ask-pass
v2.2.13 released 2015-01-26
* Feature 1391240: pt-kill added query fingerprint hash to output
* Fixed bug 1402668: pt-mysql-summary fails on cluster in Donor/Desynced status
* Fixed bug 1396870: pt-online-schema-change CTRL+C leaves terminal in inconsistent state
* Fixed bug 1396868: pt-online-schema-change --ask-pass option error
* Fixed bug 1266869: pt-stalk fails to start if $HOME environment variable is not set
* Fixed bug 1019479: pt-table-checksum does not work with sql_mode ONLY_FULL_GROUP_BY
* Fixed bug 1394934: pt-table-checksum error in debug mode
* Fixed bug 1321297: pt-table-checksum reports diffs on timestamp columns in 5.5 vs 5.6
* Fixed bug 1399789: pt-table-checksum fails to find pxc nodes when wsrep_node_incoming_address is set to AUTO
* Fixed bug 1388870: pt-table-checksum has some errors with different time zones
* Fixed bug 1408375: vulnerable to MITM attack which would allow exfiltration of MySQL configuration information via --version-check
* Fixed bug 1404298: missing MySQL5.7 test files for pt-table-checksum
* Fixed bug 1403900: added sandbox and fixed sakila test db for 5.7
v2.2.12 released 2014-11-14
* Fixed bug 1376561: pt-archiver is not able to archive all the rows when a table has a hash partition
* Fixed bug 1328686: pt-heartbeat check-read-only option does not prevent creates or inserts
* Fixed bug 1269695: pt-online-schema-change does not allow ALTER for a table without a non-unique, while manual does not explain this
* Fixed bug 1217466: pt-table-checksum refuses to run on PXC if server_id is the same on all nodes
* Fixed bug 1373937: pt-table-checksum requires recursion when working with and XtraDB Cluster node
* Fixed bug 1377888: pt-query-digest manual for --type binlog is ambiguous
* Fixed bug 1349086: pt-stalk should also gather dmesg output
* Fixed bug 1361293: Some scripts fail when no-version-check option is put in global config file
v2.2.11 released 2014-09-26
* Fixed bug 1262456: pt-query-digest doesn't report host details
* Fixed bug 1264580: pt-mysql-summary incorrectly tries to parse key/value pairs in wsrep_provider_options resulting in incomplete my.cnf information
* Fixed bug 1318985: pt-stalk should use SQL_NO_CACHE
* Fixed bug 1348679: pt-stalk handles mysql user password in awkward way
* Fixed bug 1365085: Various issues with tests
* Fixed bug 1368379: pt-summary problem parsing dmidecode output on some machines
* Fixed bug 1303388: Typo in pt-variable-advisor
v2.2.10 released 2014-08-06
* Fixed bug 1287253: pt-table-checksum deadlock
* Fixed bug 1299387: 5.6 slow query log Thead_id becomes Id
* Fixed bug 1311654: pt-table-checksum + PXC inconsistent results upon --resume
* Fixed bug 1340728: pt-online-schema-change doesn't work with HASH indexes
* Fixed bug 1253872: pt-table-checksum max load 20% rounds down
* Fixed bug 1340364: some shell tools output error when queried for --version
v2.2.9 released 2014-07-08
* Fixed bug 1258135: pt-deadlock-logger introduces a noise to MySQL
* Fixed bug 1329422: pt-online-schema-change foreign-keys-method=none breaks constraints
* Fixed bug 1315130: pt-online-schema-change not properly detecting foreign keys
* Fixed bug 1335960: pt-query-digest cannot parse binlogs from 5.6
* Fixed bug 1335322: pt-stalk fails when variable or threshold is non-integer
v2.2.8 released 2014-06-04
* Removed pt-agent
* Added pt-slave-restart GTID support
* Added pt-table-checksum --plugin
* Fixed bug 1304062: --ignore-tables does not work correctly
* Fixed bug 1295667: pt-deadlock-logger logs incorrect ts
* Fixed bug 1254233: pt-mysql-summary blank InnoDB section for 5.6
* Fixed bug 1286250: pt-online-schema-change requests password twice
* Fixed bug 965553: pt-query-digest dosn't fingerprint true/false literals correctly
* Fixed bug 290911: pt-show-grant --ask-pass prints "Enter password" to STDOUT
v2.2.7 released 2014-02-20
* Fixed bug 1279502: --version-check behaves like spyware
v2.2.6 released 2013-12-18
* Added pt-query-digest support for Percona Server slow log rate limiting
* Added pt-agent --ping
* Added pt-mysql-summary --all-databases
* Added pt-stalk --sleep-collect
* Added pt-table-sync --[no]check-child-tables
* Fixed bug 1249150: PTDEBUG prints some info to STDOUT
* Fixed bug 1248363: pt-agent requires restart after changing MySQL options
* Fixed bug 1248778: pt-agent --install on PXC is not documented
* Fixed bug 1250973: pt-agent --install doesn't check for previous install
* Fixed bug 1250968: pt-agent --install suggest MySQL user isn't quoted
* Fixed bug 1251004: pt-agent --install error about slave is confusing
* Fixed bug 1251726: pt-agent --uninstall fails if agent is running
* Fixed bug 1248785: pt-agent docs don't list privs required for its MySQL user
* Fixed bug 1215016: pt-deadlock-logger docs use pt-fk-error-logger
* Fixed bug 1201443: pt-duplicate-key-checker error when EXPLAIN key_len=0
* Fixed bug 1217013: pt-duplicate-key-checker misses exact duplicate unique indexes
* Fixed bug 1214685: pt-mysql-summary schema dump prompt can't be disabled
* Fixed bug 1195628: pt-online-schema-change gets stuck looking for its own _new table
* Fixed bug 1249149: pt-query-digest stats prints to STDOUT instead of STDERR
* Fixed bug 1071979: pt-stak error parsing df with NFS
* Fixed bug 1223458: pt-table-sync deletes child table rows
v2.2.5 released 2013-10-16
* Added Query_time histogram bucket counts to pt-query-digest JSON output
* Added pt-online-schema-change --[no]drop-triggers option
* Fixed bug 1206677: pt-agent docs reference clodu.percona.com
* Fixed bug 1226721: pt-agent on CentOS 5 fails to send data
* Fixed bug 1199589: pt-archiver deletes data despite --dry-run
* Fixed bug 1206728: pt-deadlock-logger 2.2 requires DSN on command line
* Fixed bug 1209436: pt-kill --log-dsn may not work on Perl 5.8
* Fixed bug 1215608: pt-online-schema-change new table suffix is hard-coded
* Fixed bug 821692: pt-query-digest doesn't distill LOAD DATA correctly
* Fixed bug 984053: pt-query-digest doesn't distill INSERT/REPLACE without INTO correctly
* Fixed bug 821690: pt-query-digest doesn't distill IF EXISTS correctly
* Fixed bug 1210537: pt-table-checksum --recursion-method=cluster crashes if no nodes are found
* Fixed bug 944051: pt-table-checksum has ambiguous exit status
* Fixed bug 1229861: pt-table-sync quotes float values, can't sync
v2.2.4 released 2013-07-18
* Implemented pt-query-digest anonymous JSON output
* Implemented pt-online-schema-change timestamp output
* Fixed bug 1182856: Zero values causes "Invalid --set-vars value: var=0"
* Fixed bug 1195034: pt-deadlock-logger error: Use of uninitialized value $ts in pattern match (m//)
* Fixed bug 1137556: pt-heartbeat docs don't account for --utc
* Fixed bug 1188264: pt-online-schema-change error copying rows: Undefined subroutine &pt_online_schema_change::get
* Fixed bug 1171968: pt-query-digest docs don't mention --type=rawlog
* Fixed bug 1176010: pt-query-digest doesn't group db and `db` together
* Fixed bug 1174956: pt-query-digest and pt-fingerprint don't strip some multi-line comments
* Fixed bug 1172317: pt-sift does not work if pt-stalk did not collect due to a full disk
* Fixed bug 1136559: pt-table-checksum: Deep recursion on subroutine "SchemaIterator::_iterate_dbh"
* Fixed bug 1199591: pt-table-checksum doesn't use non-unique index with highest cardinality
* Fixed bug 1163735: pt-table-checksum fails if explicit_defaults_for_timestamp is enabled in 5.6
* Fixed bug 1168434: pt-upgrade reports differences on NULL
* Fixed bug 1168106: pt-variable-advisor has the wrong default value for innodb_max_dirty_pages_pct in 5.5 and 5.6
* Fixed bug 1168110: pt-variable-advisor shows key_buffer_size in 5.6 as unconfigured (even though it is)
v2.2.3 released 2013-06-17
* Added new tool: pt-agent
* Fixed bug 1188002: pt-online-schema-change causes "ERROR 1146 (42S02): Table 'db._t_new' doesn't exist"
v2.2.2 released 2013-04-24
* Added --show-all to pt-query-digest
* Added --recursion-method=cluster to pt-table-checksum
* Fixed bug 1127450: pt-archiver --bulk-insert may corrupt data
* Fixed bug 1163372: pt-heartbeat --utc --check always returns 0
* Fixed bug 1156901: pt-query-digest --processlist reports duplicate queries for replication thread
* Fixed bug 1160338: pt-query-digest 2.2 prints unwanted debug info on tcpdump parsing errors
* Fixed bug 1160918: pt-query-digest 2.2 prints too many string values
* Fixed bug 1156867: pt-stalk prints the wrong variable name in verbose mode when --function is used
* Fixed bug 1081733: pt-stalk plugins can't access the real --prefix
* Fixed bug 1099845: pt-table-checksum pxc same_node function incorrectly uses wsrep_sst_receive_address
* Fixed bug 821502: Some tools don't have --help or --version
* Fixed bug 947893: Some tools use @@hostname without /*!50038*/
* Fixed bug 1082406: An explicitly set wsrep_node_incoming_address may make SHOW STATUS LIKE 'wsrep_incoming_addresses' return a portless address
v2.2.1 released 2013-03-14
* Official support for MySQL 5.6
* Official support for Percona XtraDB Cluster
* Redesigned pt-query-digest
* Redesigned pt-upgrade
* Redesigned pt-fk-error-logger
* Redesigned pt-deadlock-logger
* Changed --set-vars in all tools
* Renamed --retries to --tries in pt-online-schema-change
* Added --check-read-only to pt-heartbeat
* Added MySQL options to pt-mysql-summary
* Added MySQL options to pt-stalk
* Removed --lock-wait-timeout from pt-online-schema-change (use --set-vars)
* Removed --lock-wait-timeout from pt-table-checksum (use --set-vars)
* Removed pt-query-advisor
* Removed pt-tcp-model
* Removed pt-trend
* Removed pt-log-player
* Enabled --version-check by default in all tools
* Fixed bug 1008796: Several tools don't have --database
* Fixed bug 1087319: Quoter::serialize_list() doesn't handle multiple NULL values
* Fixed bug 1086018: pt-config-diff needs to parse wsrep_provider_options
* Fixed bug 1056838: pt-fk-error-logger --run-time works differently than pt-deadlock-logger --run-time
* Fixed bug 1093016: pt-online-schema-change doesn't retry RENAME TABLE
* Fixed bug 1113301: pt-online-schema-change blocks on metadata locks
* Fixed bug 1125665: pt-stalk --no-stalk silently clobbers other options, acts magically
* Fixed bug 1019648: pt-stalk truncates InnoDB status if there are too many transactions
* Fixed bug 1087804: pt-table-checksum doesn't warn if no slaves are found
v2.1.9 released 2013-02-14
* Fixed bug 1103221: pt-heartbeat 2.1.8 doesn't use precision/sub-second timestamps
* Fixed bug 1099665: pt-heartbeat 2.1.8 reports big time drift with UTC_TIMESTAMP
* Fixed bug 1099836: pt-online-schema-change fails with "Duplicate entry" on MariaDB
* Fixed bug 1103672: pt-online-schema-change makes bad DELETE trigger if PK is re-created with new columns
* Fixed bug 1115333: pt-pmp doesn't list the origin lib for each function
* Fixed bug 823411: pt-query-digest shouldn't print "Error: none" for tcpdump
* Fixed bug 1103045: pt-query-digest fails to parse non-SQL errors
* Fixed bug 1105077: pt-table-checksum: Confusing error message with binlog_format ROW or MIXED on slave
* Fixed bug 918056: pt-table-sync false-positive error "Cannot nibble table because MySQL chose no index instead of the PRIMARY index"
* Fixed bug 1099933: pt-stalk is too verbose, fills up log
v2.1.8 released 2012-12-21
* Beta support for MySQL 5.6
* Beta support for Percona XtraDB Cluster
* pt-online-schema-change: If ran on Percona XtraDB Cluster, requires PXC 5.5.28 or newer
* pt-table-checksum: If ran on Percona XtraDB Cluster, requires PXC 5.5.28 or newer
* pt-upgrade: Added --[no]disable-query-cache
* Fixed bug 927955: Bad pod2rst transformation
* Fixed bug 898665: Bad online docs formatting for --[no]vars
* Fixed bug 1022622: pt-config-diff is case-sensitive
* Fixed bug 1007938: pt-config-diff doesn't handle end-of-line comments
* Fixed bug 917770: pt-config-diff Use of uninitialized value in substitution (s///) at line 1996
* Fixed bug 1082104: pt-deadlock-logger doesn't handle usernames with dashes
* Fixed bug 886059: pt-heartbeat handles timezones inconsistently
* Fixed bug 1086259: pt-kill --log-dsn timestamp is wrong
* Fixed bug 1015590: pt-mysql-summary doesn't handle renamed variables in Percona Server 5.5
* Fixed bug 1079341: pt-online-schema-change checks for foreign keys on MyISAM tables
* Fixed bug 823431: pt-query-advisor hangs on big queries
* Fixed bug 996069: pt-query-advisor RES.001 is incorrect
* Fixed bug 933465: pt-query-advisor false positive on RES.001
* Fixed bug 937234: pt-query-advisor issues wrong RES.001
* Fixed bug 1082599: pt-query-digest fails to parse timestamp with no query
* Fixed bug 1078838: pt-query-digest doesn't parse general log with "Connect user as user"
* Fixed bug 957442: pt-query-digest with custom --group-by throws error
* Fixed bug 887638: pt-query-digest prints negative byte offset
* Fixed bug 831525: pt-query-digest help output mangled
* Fixed bug 932614: pt-slave-restart CHANGE MASTER query causes error
* Fixed bug 1046440: pt-stalk purge_samples slows down checks
* Fixed bug 986847: pt-stalk does not report NFS iostat
* Fixed bug 1074179: pt-table-checksum doesn't ignore tables for --replicate-check-only
* Fixed bug 911385: pt-table-checksum v2 fails when --resume + --ignore-database is used
* Fixed bug 1041391: pt-table-checksum debug statement for "Chosen hash func" prints undef
* Fixed bug 1075638: pt-table-checksum Illegal division by zero at line 7950
* Fixed bug 1052475: pt-table-checksum uninitialized value in numeric lt (<) at line 8611
* Fixed bug 1078887: Tools let --set-vars clobber the required SQL mode
v2.1.7 released 2012-11-19
* Fixed bug 1080384: pt-table-checksum 2.1.6 crashes using PTDEBUG
* Fixed bug 1080385: pt-table-checksum 2.1.6 --check-binlog-format doesn't ignore PXC nodes
v2.1.6 released 2012-11-13
* pt-online-schema-change: Columns can now be renamed without data loss
* pt-online-schema-change: New --default-engine option
* pt-stalk: Plugin hooks available through the --plugin option to extend the tool's functionality
* Fixed bug 1069951: --version-check default should be explicitly "off"
* Fixed bug 821715: LOAD DATA LOCAL INFILE broken in some platforms
* Fixed bug 995896: Useless use of cat in Daemon.pm
* Fixed bug 1039074: Tools exit 0 on error parsing options, should exit non-zero
* Fixed bug 938068: pt-table-checksum doesn't warn if binlog_format=row or mixed on slaves
* Fixed bug 1009510: pt-table-checksum breaks replication if a slave table is missing or different
* Fixed bug 1043438: pt-table-checksum doesn't honor --run-time while checking replication lag
* Fixed bug 1073532: pt-table-checksum error: Use of uninitialized value in int at line 2778
* Fixed bug 1016131: pt-table-checksum can crash with --columns if none match
* Fixed bug 1039569: pt-table-checksum dies if creating the --replicate table fails
* Fixed bug 1059732: pt-table-checksum doesn't test all hash functions
* Fixed bug 1062563: pt-table-checksum 2.1.4 doesn't detect diffs on Percona XtraDB Cluster nodes
* Fixed bug 1043528: pt-deadlock-logger can't parse db/tbl/index on partitioned tables
* Fixed bug 1062324: pt-online-schema-change DELETE trigger fails when altering primary key
* Fixed bug 1058285: pt-online-schema-change fails if sql_mode explicitly or implicitly uses ANSI_QUOTES
* Fixed bug 1073996: pt-online-schema-change fails with "I need a max_rows argument"
* Fixed bug 1039541: pt-online-schema-change --quiet doesn't disable --progress
* Fixed bug 1045317: pt-online-schema-change doesn't report how many warnings it suppressed
* Fixed bug 1060774: pt-upgrade fails if select column > 64 chars
* Fixed bug 1070916: pt-mysql-summary may report the wrong cnf file
* Fixed bug 903229: pt-mysql-summary incorrectly categorizes databases
* Fixed bug 866075: pt-show-grant doesn't support column-level grants
* Fixed bug 978133: pt-query-digest review table privilege checks don't work
* Fixed bug 956981: pt-query-digest docs for event attributes link to defunct Maatkit wiki
* Fixed bug 1047335: pt-duplicate-key-checker fails when it encounters a crashed table
* Fixed bug 1047701: pt-stalk deletes non-empty files
* Fixed bug 1070434: pt-stalk --no-stalk and --iterations 1 don't wait for the collect
* Fixed bug 1052722: pt-fifo-split is processing n-1 rows initially
* Fixed bug 1013407: pt-find documentation error with mtime and InnoDB
* Fixed bug 1059757: pt-trend output has no header
* Fixed bug 1063933: pt-visual-explain docs link to missing pdf
* Fixed bug 1075773: pt-fk-error-logger crashes if there's no foreign key error
* Fixed bug 1075775: pt-fk-error-logger --dest table example doesn't work
v2.1.5 released 2012-10-08
* Fixed bug 1062563: pt-table-checksum 2.1.4 doesn't detect diffs on Percona XtraDB Cluster nodes
* Fixed bug 1063912: pt-table-checksum 2.1.4 miscategorizes Percona XtraDB Cluster-based slaves as cluster nodes
* Fixed bug 1064016: pt-table-sync 2.1.4 --version-check may not work with HTTPS/SSL
* Fixed bug 1060423: Missing version-check page
v2.1.4 released 2012-09-20
* pt-table-checksum: Percona XtraDB Cluster support
* pt-table-checksum: Implemented the standard --run-time option
* Implemented the version-check feature in several tools, enabled with the --version-check option
* Fixed bug 856060: Document gdb dependency
* Fixed bug 1041394: Unquoted arguments to tr break the bash tools
* Fixed bug 1035311: pt-diskstats shows wrong device names
* Fixed bug 1036804: pt-duplicate-key-checker error parsing InnoDB table with no PK or unique keys
* Fixed bug 1022658: pt-online-schema-change dropping FK limitation isn't documented
* Fixed bug 1041372: pt-online-schema-changes fails if db+tbl name exceeds 64 characters
* Fixed bug 1029178: pt-query-digest --type tcpdump memory usage keeps increasing
* Fixed bug 1037211: pt-query-digest won't distill LOCK TABLES in lowercase
* Fixed bug 942114: pt-stalk warns about bad "find" usage
* Fixed bug 1035319: pt-stalk df -h throws away needed details
* Fixed bug 1038995: pt-stalk --notify-by-email fails
* Fixed bug 1038995: pt-stalk does not get all InnoDB lock data
* Fixed bug 952722: pt-summary should show information about Fusion-io cards
* Fixed bug 899415: pt-table-checksum doesn't work if slaves use RBR
* Fixed bug 954588: pt-table-checksum --check-slave-lag docs aren't clear
* Fixed bug 1034170: pt-table-checksum --defaults-file isn't used for slaves
* Fixed bug 930693: pt-table-sync and text columns with just whitespace
* Fixed bug 1028710: pt-table-sync base_count fails on n = 1000, base = 10
* Fixed bug 1034717: pt-table-sync division by zero error with varchar primary key
* Fixed bug 1036747: pt-table-sync priv checks need to be removed
* Fixed bug 1039184: pt-upgrade error "I need a right_sth argument"
* Fixed bug 1035260: sh warnings in pt-summary and pt-mysql-summary
* Fixed bug 1038276: ChangeHandler doesn't quote varchar columns with hex-looking values
* Fixed bug 916925: CentOS 5 yum dependency resolution for perl module is wrong
* Fixed bug 1035950: Percona Toolkit RPM should contain a dependency on perl-Time-HiRes
v2.1.3 released 2012-08-03
* pt-kill: Implemented --log-dsn to log info about killed queries to a table
* Fixed bug 1016127: Install hint for DBD::mysql is wrong
* Fixed bug 984915: DSNParser does not check success of --set-vars
* Fixed bug 889739: pt-config-diff doesn't diff quoted strings properly
* Fixed bug 969669: pt-duplicate-key-checker --key-types=k doesn't work
* Fixed bug 1004567: pt-heartbeat --update --replace causes duplicate key error
* Fixed bug 1028614: pt-index-usage ignores --database
* Fixed bug 940733: pt-ioprofile leaves behind temp directory
* Fixed bug 941469: pt-kill doesn't reconnect if its connection is lost
* Fixed bug 1016114: pt-online-schema-change docs don't mention default values
* Fixed bug 1020997: pt-online-schema-change fails when table is empty
* Fixed bug 1022628: pt-online-schema-change error: Use of uninitialized value in numeric lt (<) at line 6519
* Fixed bug 937225: pt-query-advisor OUTER JOIN advice in JOI.003 is confusing
* Fixed bug 821703: pt-query-digest --processlist may crash
* Fixed bug 883098: pt-query-digest crashes if processlist has extra columns
* Fixed bug 924950: pt-query-digest --group-by db may crash profile report
* Fixed bug 1022851: pt-sift error: PREFIX: unbound variable
* Fixed bug 969703: pt-sift defaults to '.' instead of '/var/lib/pt-talk'
* Fixed bug 962330: pt-slave-delay incorrectly computes lag if started when slave is already lagging
* Fixed bug 954990: pt-stalk --nostalk does not work
* Fixed bug 977226: pt-summary doesn't detect LSI RAID control
* Fixed bug 1030031: pt-table-checksum reports wrong number of DIFFS
* Fixed bug 916168: pt-table-checksum privilege check fails on MySQL 5.5
* Fixed bug 950294: pt-table-checksum should always create schema and tables with IF NOT EXISTS
* Fixed bug 953141: pt-table-checksum ignores its default and explicit --recursion-method
* Fixed bug 1030975: pt-table-sync crashes if sql_mode includes ANSI_QUOTES
* Fixed bug 869005: pt-table-sync should always set REPEATABLE READ
* Fixed bug 903510: pt-tcp-model crashes in --type=requests mode on empty file
* Fixed bug 934310: pt-tcp-model --quantile docs wrong
* Fixed bug 980318: pt-upgrade results truncated if hostnames are long
* Fixed bug 821696: pt-variable-advisor shows too long of a snippet
* Fixed bug 844880: pt-variable-advisor shows binary logging as both enabled and disabled
v2.1.2 released 2012-06-12
* pt-heartbeat: Implemented --recursion-method=none
* pt-index-usage: MySQL 5.5 compatibility fixes
* pt-log-player: MySQL 5.5 compatibility fixes
* pt-online-schema-change: Added --chunk-index-columns
* pt-online-schema-change: Added --[no]check-plan
* pt-online-schema-change: Added --[no]drop-new-table
* pt-online-schema-change: Implemented --recursion-method=none
* pt-query-advisor: Added --report-type for JSON output
* pt-query-digest: Removed --[no]zero-bool
* pt-slave-delay: Added --database
* pt-slave-find: Implemented --recursion-method=none
* pt-slave-restart: Implemented --recursion-method=none
* pt-table-checksum: Added --chunk-index-columns
* pt-table-checksum: Added --[no]check-plan
* pt-table-checksum: Implemented --recursion-method=none
* pt-table-sync: Disabled --lock-and-rename except for MySQL 5.5 and newer
* pt-table-sync: Implemented --recursion-method=none
* Fixed bug 945079: Shell tools TMPDIR may break
* Fixed bug 912902: Some shell tools still use basename
* Fixed bug 987694: There is no --recursion-method=none option
* Fixed bug 886077: Passwords with commas don't work, expose part of password
* Fixed bug 856024: Lintian warnings when building percona-toolkit Debian package
* Fixed bug 903379: pt-archiver --file doesn't create a file
* Fixed bug 979092: pt-archiver --sleep conflicts with bulk operations
* Fixed bug 903443: pt-deadlock-logger crashes on MySQL 5.5
* Fixed bug 941064: pt-deadlock-logger can't clear deadlocks on 5.5
* Fixed bug 952727: pt-diskstats shows incorrect wr_mb_s
* Fixed bug 994176: pt-diskstats --group-by=all --headers=scroll prints a header for every sample
* Fixed bug 894140: pt-duplicate-key-checker sometimes recreates a key it shouldn't
* Fixed bug 923896: pt-kill: uninitialized value causes script to exit
* Fixed bug 1003003: pt-online-schema-change uses different keys for chunking and triggers
* Fixed bug 1003315: pt-online-schema-change --dry-run always fails on table with foreign keys
* Fixed bug 1004551: pt-online-schema-change --no-swap-tables causes error
* Fixed bug 976108: pt-online-schema-change doesn't allow to disable foreign key checks
* Fixed bug 976109: pt-online-schema-change doesn't handle column renames
* Fixed bug 988036: pt-online-schema-change causes deadlocks under heavy write load
* Fixed bug 989227: pt-online-schema-change crashes with PTDEBUG
* Fixed bug 994002: pt-online-schema-change 2.1.1 doesn't choose the PRIMARY KEY
* Fixed bug 994010: pt-online-schema-change 2.1.1 crashes without InnoDB
* Fixed bug 996915: pt-online-schema-change crashes with invalid --max-load and --critical-load
* Fixed bug 998831: pt-online-schema-change -- Should have an option to NOT drop tables on failure
* Fixed bug 1002448: pt-online-schema-change: typo for finding usable indexes
* Fixed bug 885382: pt-query-digest --embedded-attributes doesn't check cardinality
* Fixed bug 888114: pt-query-digest report crashes with infinite loop
* Fixed bug 949630: pt-query-digest mentions a Subversion repository
* Fixed bug 844034: pt-show-grants --separate fails with proxy user
* Fixed bug 946707: pt-sift loses STDIN after pt-diskstats
* Fixed bug 994947: pt-stalk doesn't reset cycles_true after collection
* Fixed bug 986151: pt-stalk-has mktemp error
* Fixed bug 993436: pt-summary Memory: Total reports M instead of G
* Fixed bug 1008778: pt-table-checksum doesn't wait for checksum table to replicate
* Fixed bug 1010232: pt-table-checksum doesn't check the size of checksum chunks
* Fixed bug 1011738: pt-table-checksum SKIPPED is zero but chunks were skipped
* Fixed bug 919499: pt-table-checksum fails with binary log error in mysql >= 5.5.18
* Fixed bug 972399: pt-table-checksum docs are not rendered right
* Fixed bug 978432: pt-table-checksum ignoring primary key
* Fixed bug 995274: pt-table-checksum can't use an undefined value as an ARRAY reference at line 2206
* Fixed bug 996110: pt-table-checksum crashes if InnoDB is disabled
* Fixed bug 987393: pt-table-checksum: Empy tables cause "undefined value as an ARRAY" errors
* Fixed bug 997155: pt-table-sync sets binlog_format needlessly
* Fixed bug 1002365: pt-table-sync --ignore-* options don't work with --replicate
* Fixed bug 1003014: pt-table-sync --replicate and --sync-to-master error "index does not exist"
* Fixed bug 823403: pt-table-sync --lock-and-rename doesn't work on 5.1
* Fixed bug 898138: pt-variable-advisor doesn't recognize 5.5.3+ concurrent_insert values
v2.1.1 released 2012-04-03
* Completely redesigned pt-online-schema-change
* Completely redesigned pt-mysql-summary
* Completely redesigned pt-summary
* Added new tool: pt-table-usage
* Added new tool: pt-fingerprint
* Fixed bug 955860: pt-stalk doesn't run vmstat, iostat, and mpstat for --run-time
* Fixed bug 960513: SHOW TABLE STATUS is used needlessly
* Fixed bug 969726: pt-online-schema-change loses foreign keys
* Fixed bug 846028: pt-online-schema-change does not show progress until completed
* Fixed bug 898695: pt-online-schema-change add useless ORDER BY
* Fixed bug 952727: pt-diskstats shows incorrect wr_mb_s
* Fixed bug 963225: pt-query-digest fails to set history columns for disk tmp tables and disk filesort
* Fixed bug 967451: Char chunking doesn't quote column name
* Fixed bug 972399: pt-table-checksum docs are not rendered right
* Fixed bug 896553: Various documentation spelling fixes
* Fixed bug 949154: pt-variable-advisor advice for relay-log-space-limit
* Fixed bug 953461: pt-upgrade manual broken 'output' section
* Fixed bug 949653: pt-table-checksum docs don't mention risks posed by inconsistent schemas
v2.0.4 released 2012-03-07
* Added --filter to pt-kill to allow arbitrary --group-by
* Added --[no]stalk to pt-stalk (bug 932331)
* Added --execute to pt-online-schema-change (bug 933232)
* Fixed bug 873598: pt-online-schema-change doesn't like reserved words in column names
* Fixed bug 928966: pt-pmp still uses insecure /tmp
* Fixed bug 933232: pt-online-schema-change can break replication
* Fixed bug 941225: Use of qw(...) as parentheses is deprecated at pt-kill line 3511
* Fixed bug 821694: pt-query-digest doesn't recognize hex InnoDB txn IDs
* Fixed bug 894255: pt-kill shouldn't check if STDIN is a tty when --daemonize is given
* Fixed bug 916999: pt-table-checksum error: DBD::mysql::st execute failed: called with 2 bind variables when 6 are needed
* Fixed bug 926598: DBD::mysql bug causes pt-upgrade to use wrong precision (M) and scale (D)
* Fixed bug 928226: pt-diskstats illegal division by zero
* Fixed bug 928415: Typo in pt-stalk doc: --trigger should be --function
* Fixed bug 930317: pt-archiver doc refers to nonexistent pt-query-profiler
* Fixed bug 930533: pt-sift looking for *-processlist1; broken compatibility with pt-stalk
* Fixed bug 932331: pt-stalk cannot collect without stalking
* Fixed bug 932442: pt-table-checksum error when column name has two spaces
* Fixed bug 932883: File Debian bug after each release
* Fixed bug 940503: pt-stalk disk space checks wrong on 32bit platforms
* Fixed bug 944420: --daemonize doesn't always close STDIN
* Fixed bug 945834: pt-sift invokes pt-diskstats with deprecated argument
* Fixed bug 945836: pt-sift prints awk error if there are no stack traces to aggregate
* Fixed bug 945842: pt-sift generates wrong state sum during processlist analysis
* Fixed bug 946438: pt-query-digest should print a better message when an unsupported log format is specified
* Fixed bug 946776: pt-table-checksum ignores --lock-wait-timeout
* Fixed bug 940440: Bad grammar in pt-kill docs
v2.0.3 released 2012-02-03
* Completely redesigned pt-diskstats
* Completely redesigned pt-stalk
* Removed pt-collect and put its functionality in pt-stalk
* Fixed bug 871438: Bash tools are insecure
* Fixed bug 897758: Failed to prepare TableSyncChunk plugin: Use of uninitialized value $args{"chunk_range"} in lc at pt-table-sync line 3055
* Fixed bug 919819: pt-kill --execute-command creates zombies
* Fixed bug 925778: pt-ioprofile doesn't run without a file
* Fixed bug 925477: pt-ioprofile docs refer to pt-iostats
* Fixed bug 857091: pt-sift downloads http://percona.com/get/pt-pmp, which does not work
* Fixed bug 857104: pt-sift tries to invoke mext, should be pt-mext
* Fixed bug 872699: pt-diskstats: rd_avkb & wr_avkb derived incorrectly
* Fixed bug 897029: pt-diskstats computes wrong values for md0
* Fixed bug 882918: pt-stalk spams warning if oprofile isn't installed
* Fixed bug 884504: pt-stalk doesn't check pt-collect
* Fixed bug 897483: pt-online-schema-change "uninitialized value" due to update-foreign-keys-method
* Fixed bug 925007: pt-online-schema-change Use of uninitialized value $tables{"old_table"} in concatenation (.) or string at line 4330
* Fixed bug 915598: pt-config-diff ignores --ask-pass option
* Fixed bug 919352: pt-table-checksum changes binlog_format even if already set to statement
* Fixed bug 921700: pt-table-checksum doesn't add --where to chunk size test on replicas
* Fixed bug 921802: pt-table-checksum does not recognize --recursion-method=processlist
* Fixed bug 925855: pt-table-checksum index check is case-sensitive
* Fixed bug 821709: pt-show-grants --revoke and --separate don't work together
* Fixed bug 918247: Some tools use VALUE instead of VALUES
v2.0.2 released 2012-01-05
* Fixed bug 911996: pt-table-sync --replicate causes "Unknown column" error
v2.0.1 released 2011-12-30
* Completely redesigned pt-table-checksum
* Fixed bug 856065: pt-trend does not work
* Fixed bug 887688: Prepared statements crash pt-query-digest
* Fixed bug 888286: align not part of percona-toolkit
* Fixed bug 897961: ptc 2.0 replicate-check error does not include hostname
* Fixed bug 898318: ptc 2.0 --resume with --tables does not always work
* Fixed bug 903513: MKDEBUG should be PTDEBUG
* Fixed bug 908256: Percona Toolkit should include pt-ioprofile
* Fixed bug 821717: pt-tcp-model --type=requests crashes
* Fixed bug 844038: pt-online-schema-change documentation example w/drop-tmp-table does not work
* Fixed bug 864205: Remove the query to reset @crc from pt-table-checksum
* Fixed bug 898663: Typo in pt-log-player documentation
v1.0.1 released 2011-09-01
* Fixed bug 819421: MasterSlave::is_replication_thread() doesn't match all
* Fixed bug 821673: pt-table-checksum doesn't include --where in min max queries
* Fixed bug 821688: pt-table-checksum SELECT MIN MAX for char chunking is wrong
* Fixed bug 838211: pt-collect: line 24: [: : integer expression expected
* Fixed bug 838248: pt-collect creates a "5.1" file
v0.9.5 released 2011-08-04
* Forked, combined, and rebranded Maatkit and Aspersa as Percona Toolkit.
percona-toolkit-2.2.16/README 0000644 0001750 0001750 00000002273 12617202747 015476 0 ustar vagrant vagrant Percona Toolkit
===============
Percona Toolkit is a collection of advanced command-line tools used by
Percona (http://www.percona.com/) support staff to perform a variety of
MySQL and system tasks that are too difficult or complex to perform manually.
These tools are ideal alternatives to private or "one-off" scripts because
they are professionally developed, formally tested, and fully documented.
They are also fully self-contained, so installation is quick and easy and
no libraries are installed.
Percona Toolkit is developed and supported by Percona Inc. For more
information and other free, open-source software developed by Percona,
visit http://www.percona.com/software/.
Installing
----------
To install all tools, run:
perl Makefile.PL
make
make test
make install
You probably need to be root to `make install'. On most systems, the tools
are installed in /usr/local/bin. See the INSTALL file for more information.
Documentation
-------------
Run `man percona-toolkit' to see a list of installed tools, then `man tool'
to read the embedded documentation for a specific tool. You can also read
the documentation online at http://www.percona.com/software/percona-toolkit/.
percona-toolkit-2.2.16/COPYING 0000644 0001750 0001750 00000043254 12617202747 015655 0 ustar vagrant vagrant GNU GENERAL PUBLIC LICENSE
Version 2, June 1991
Copyright (C) 1989, 1991 Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
Everyone is permitted to copy and distribute verbatim copies
of this license document, but changing it is not allowed.
Preamble
The licenses for most software are designed to take away your
freedom to share and change it. By contrast, the GNU General Public
License is intended to guarantee your freedom to share and change free
software--to make sure the software is free for all its users. This
General Public License applies to most of the Free Software
Foundation's software and to any other program whose authors commit to
using it. (Some other Free Software Foundation software is covered by
the GNU Lesser General Public License instead.) You can apply it to
your programs, too.
When we speak of free software, we are referring to freedom, not
price. Our General Public Licenses are designed to make sure that you
have the freedom to distribute copies of free software (and charge for
this service if you wish), that you receive source code or can get it
if you want it, that you can change the software or use pieces of it
in new free programs; and that you know you can do these things.
To protect your rights, we need to make restrictions that forbid
anyone to deny you these rights or to ask you to surrender the rights.
These restrictions translate to certain responsibilities for you if you
distribute copies of the software, or if you modify it.
For example, if you distribute copies of such a program, whether
gratis or for a fee, you must give the recipients all the rights that
you have. You must make sure that they, too, receive or can get the
source code. And you must show them these terms so they know their
rights.
We protect your rights with two steps: (1) copyright the software, and
(2) offer you this license which gives you legal permission to copy,
distribute and/or modify the software.
Also, for each author's protection and ours, we want to make certain
that everyone understands that there is no warranty for this free
software. If the software is modified by someone else and passed on, we
want its recipients to know that what they have is not the original, so
that any problems introduced by others will not reflect on the original
authors' reputations.
Finally, any free program is threatened constantly by software
patents. We wish to avoid the danger that redistributors of a free
program will individually obtain patent licenses, in effect making the
program proprietary. To prevent this, we have made it clear that any
patent must be licensed for everyone's free use or not licensed at all.
The precise terms and conditions for copying, distribution and
modification follow.
GNU GENERAL PUBLIC LICENSE
TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION
0. This License applies to any program or other work which contains
a notice placed by the copyright holder saying it may be distributed
under the terms of this General Public License. The "Program", below,
refers to any such program or work, and a "work based on the Program"
means either the Program or any derivative work under copyright law:
that is to say, a work containing the Program or a portion of it,
either verbatim or with modifications and/or translated into another
language. (Hereinafter, translation is included without limitation in
the term "modification".) Each licensee is addressed as "you".
Activities other than copying, distribution and modification are not
covered by this License; they are outside its scope. The act of
running the Program is not restricted, and the output from the Program
is covered only if its contents constitute a work based on the
Program (independent of having been made by running the Program).
Whether that is true depends on what the Program does.
1. You may copy and distribute verbatim copies of the Program's
source code as you receive it, in any medium, provided that you
conspicuously and appropriately publish on each copy an appropriate
copyright notice and disclaimer of warranty; keep intact all the
notices that refer to this License and to the absence of any warranty;
and give any other recipients of the Program a copy of this License
along with the Program.
You may charge a fee for the physical act of transferring a copy, and
you may at your option offer warranty protection in exchange for a fee.
2. You may modify your copy or copies of the Program or any portion
of it, thus forming a work based on the Program, and copy and
distribute such modifications or work under the terms of Section 1
above, provided that you also meet all of these conditions:
a) You must cause the modified files to carry prominent notices
stating that you changed the files and the date of any change.
b) You must cause any work that you distribute or publish, that in
whole or in part contains or is derived from the Program or any
part thereof, to be licensed as a whole at no charge to all third
parties under the terms of this License.
c) If the modified program normally reads commands interactively
when run, you must cause it, when started running for such
interactive use in the most ordinary way, to print or display an
announcement including an appropriate copyright notice and a
notice that there is no warranty (or else, saying that you provide
a warranty) and that users may redistribute the program under
these conditions, and telling the user how to view a copy of this
License. (Exception: if the Program itself is interactive but
does not normally print such an announcement, your work based on
the Program is not required to print an announcement.)
These requirements apply to the modified work as a whole. If
identifiable sections of that work are not derived from the Program,
and can be reasonably considered independent and separate works in
themselves, then this License, and its terms, do not apply to those
sections when you distribute them as separate works. But when you
distribute the same sections as part of a whole which is a work based
on the Program, the distribution of the whole must be on the terms of
this License, whose permissions for other licensees extend to the
entire whole, and thus to each and every part regardless of who wrote it.
Thus, it is not the intent of this section to claim rights or contest
your rights to work written entirely by you; rather, the intent is to
exercise the right to control the distribution of derivative or
collective works based on the Program.
In addition, mere aggregation of another work not based on the Program
with the Program (or with a work based on the Program) on a volume of
a storage or distribution medium does not bring the other work under
the scope of this License.
3. You may copy and distribute the Program (or a work based on it,
under Section 2) in object code or executable form under the terms of
Sections 1 and 2 above provided that you also do one of the following:
a) Accompany it with the complete corresponding machine-readable
source code, which must be distributed under the terms of Sections
1 and 2 above on a medium customarily used for software interchange; or,
b) Accompany it with a written offer, valid for at least three
years, to give any third party, for a charge no more than your
cost of physically performing source distribution, a complete
machine-readable copy of the corresponding source code, to be
distributed under the terms of Sections 1 and 2 above on a medium
customarily used for software interchange; or,
c) Accompany it with the information you received as to the offer
to distribute corresponding source code. (This alternative is
allowed only for noncommercial distribution and only if you
received the program in object code or executable form with such
an offer, in accord with Subsection b above.)
The source code for a work means the preferred form of the work for
making modifications to it. For an executable work, complete source
code means all the source code for all modules it contains, plus any
associated interface definition files, plus the scripts used to
control compilation and installation of the executable. However, as a
special exception, the source code distributed need not include
anything that is normally distributed (in either source or binary
form) with the major components (compiler, kernel, and so on) of the
operating system on which the executable runs, unless that component
itself accompanies the executable.
If distribution of executable or object code is made by offering
access to copy from a designated place, then offering equivalent
access to copy the source code from the same place counts as
distribution of the source code, even though third parties are not
compelled to copy the source along with the object code.
4. You may not copy, modify, sublicense, or distribute the Program
except as expressly provided under this License. Any attempt
otherwise to copy, modify, sublicense or distribute the Program is
void, and will automatically terminate your rights under this License.
However, parties who have received copies, or rights, from you under
this License will not have their licenses terminated so long as such
parties remain in full compliance.
5. You are not required to accept this License, since you have not
signed it. However, nothing else grants you permission to modify or
distribute the Program or its derivative works. These actions are
prohibited by law if you do not accept this License. Therefore, by
modifying or distributing the Program (or any work based on the
Program), you indicate your acceptance of this License to do so, and
all its terms and conditions for copying, distributing or modifying
the Program or works based on it.
6. Each time you redistribute the Program (or any work based on the
Program), the recipient automatically receives a license from the
original licensor to copy, distribute or modify the Program subject to
these terms and conditions. You may not impose any further
restrictions on the recipients' exercise of the rights granted herein.
You are not responsible for enforcing compliance by third parties to
this License.
7. If, as a consequence of a court judgment or allegation of patent
infringement or for any other reason (not limited to patent issues),
conditions are imposed on you (whether by court order, agreement or
otherwise) that contradict the conditions of this License, they do not
excuse you from the conditions of this License. If you cannot
distribute so as to satisfy simultaneously your obligations under this
License and any other pertinent obligations, then as a consequence you
may not distribute the Program at all. For example, if a patent
license would not permit royalty-free redistribution of the Program by
all those who receive copies directly or indirectly through you, then
the only way you could satisfy both it and this License would be to
refrain entirely from distribution of the Program.
If any portion of this section is held invalid or unenforceable under
any particular circumstance, the balance of the section is intended to
apply and the section as a whole is intended to apply in other
circumstances.
It is not the purpose of this section to induce you to infringe any
patents or other property right claims or to contest validity of any
such claims; this section has the sole purpose of protecting the
integrity of the free software distribution system, which is
implemented by public license practices. Many people have made
generous contributions to the wide range of software distributed
through that system in reliance on consistent application of that
system; it is up to the author/donor to decide if he or she is willing
to distribute software through any other system and a licensee cannot
impose that choice.
This section is intended to make thoroughly clear what is believed to
be a consequence of the rest of this License.
8. If the distribution and/or use of the Program is restricted in
certain countries either by patents or by copyrighted interfaces, the
original copyright holder who places the Program under this License
may add an explicit geographical distribution limitation excluding
those countries, so that distribution is permitted only in or among
countries not thus excluded. In such case, this License incorporates
the limitation as if written in the body of this License.
9. The Free Software Foundation may publish revised and/or new versions
of the General Public License from time to time. Such new versions will
be similar in spirit to the present version, but may differ in detail to
address new problems or concerns.
Each version is given a distinguishing version number. If the Program
specifies a version number of this License which applies to it and "any
later version", you have the option of following the terms and conditions
either of that version or of any later version published by the Free
Software Foundation. If the Program does not specify a version number of
this License, you may choose any version ever published by the Free Software
Foundation.
10. If you wish to incorporate parts of the Program into other free
programs whose distribution conditions are different, write to the author
to ask for permission. For software which is copyrighted by the Free
Software Foundation, write to the Free Software Foundation; we sometimes
make exceptions for this. Our decision will be guided by the two goals
of preserving the free status of all derivatives of our free software and
of promoting the sharing and reuse of software generally.
NO WARRANTY
11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY
FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN
OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES
PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED
OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF
MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS
TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE
PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,
REPAIR OR CORRECTION.
12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING
WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR
REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,
INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING
OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED
TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY
YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER
PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE
POSSIBILITY OF SUCH DAMAGES.
END OF TERMS AND CONDITIONS
How to Apply These Terms to Your New Programs
If you develop a new program, and you want it to be of the greatest
possible use to the public, the best way to achieve this is to make it
free software which everyone can redistribute and change under these terms.
To do so, attach the following notices to the program. It is safest
to attach them to the start of each source file to most effectively
convey the exclusion of warranty; and each file should have at least
the "copyright" line and a pointer to where the full notice is found.
Copyright (C)
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License along
with this program; if not, write to the Free Software Foundation, Inc.,
51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA.
Also add information on how to contact you by electronic and paper mail.
If the program is interactive, make it output a short notice like this
when it starts in an interactive mode:
Gnomovision version 69, Copyright (C) year name of author
Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'.
This is free software, and you are welcome to redistribute it
under certain conditions; type `show c' for details.
The hypothetical commands `show w' and `show c' should show the appropriate
parts of the General Public License. Of course, the commands you use may
be called something other than `show w' and `show c'; they could even be
mouse-clicks or menu items--whatever suits your program.
You should also get your employer (if you work as a programmer) or your
school, if any, to sign a "copyright disclaimer" for the program, if
necessary. Here is a sample; alter the names:
Yoyodyne, Inc., hereby disclaims all copyright interest in the program
`Gnomovision' (which makes passes at compilers) written by James Hacker.
, 1 April 1989
Ty Coon, President of Vice
This General Public License does not permit incorporating your program into
proprietary programs. If your program is a subroutine library, you may
consider it more useful to permit linking proprietary applications with the
library. If this is what you want to do, use the GNU Lesser General
Public License instead of this License.
percona-toolkit-2.2.16/bin/ 0000755 0001750 0001750 00000000000 12617202747 015362 5 ustar vagrant vagrant percona-toolkit-2.2.16/bin/pt-heartbeat 0000755 0001750 0001750 00000565741 12617202747 017712 0 ustar vagrant vagrant #!/usr/bin/env perl
# This program is part of Percona Toolkit: http://www.percona.com/software/
# See "COPYRIGHT, LICENSE, AND WARRANTY" at the end of this file for legal
# notices and disclaimers.
use strict;
use warnings FATAL => 'all';
# This tool is "fat-packed": most of its dependent modules are embedded
# in this file. Setting %INC to this file for each module makes Perl aware
# of this so it will not try to load the module from @INC. See the tool's
# documentation for a full list of dependencies.
BEGIN {
$INC{$_} = __FILE__ for map { (my $pkg = "$_.pm") =~ s!::!/!g; $pkg } (qw(
Percona::Toolkit
MasterSlave
OptionParser
DSNParser
Daemon
Quoter
TableParser
Retry
Transformers
HTTP::Micro
VersionCheck
));
}
# ###########################################################################
# Percona::Toolkit package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Percona/Toolkit.pm
# t/lib/Percona/Toolkit.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Percona::Toolkit;
our $VERSION = '2.2.15';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Carp qw(carp cluck);
use Data::Dumper qw();
require Exporter;
our @ISA = qw(Exporter);
our @EXPORT_OK = qw(
have_required_args
Dumper
_d
);
sub have_required_args {
my ($args, @required_args) = @_;
my $have_required_args = 1;
foreach my $arg ( @required_args ) {
if ( !defined $args->{$arg} ) {
$have_required_args = 0;
carp "Argument $arg is not defined";
}
}
cluck unless $have_required_args; # print backtrace
return $have_required_args;
}
sub Dumper {
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
Data::Dumper::Dumper(@_);
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Percona::Toolkit package
# ###########################################################################
# ###########################################################################
# MasterSlave package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MasterSlave.pm
# t/lib/MasterSlave.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MasterSlave;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub check_recursion_method {
my ($methods) = @_;
if ( @$methods != 1 ) {
if ( grep({ !m/processlist|hosts/i } @$methods)
&& $methods->[0] !~ /^dsn=/i )
{
die "Invalid combination of recursion methods: "
. join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". "
. "Only hosts and processlist may be combined.\n"
}
}
else {
my ($method) = @$methods;
die "Invalid recursion method: " . ( $method || 'undef' )
unless $method && $method =~ m/^(?:processlist$|hosts$|none$|dsn=)/i;
}
}
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(OptionParser DSNParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
%args,
replication_thread => {},
};
return bless $self, $class;
}
sub get_slaves {
my ($self, %args) = @_;
my @required_args = qw(make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($make_cxn) = @args{@required_args};
my $slaves = [];
my $dp = $self->{DSNParser};
my $methods = $self->_resolve_recursion_methods($args{dsn});
return $slaves unless @$methods;
if ( grep { m/processlist|hosts/i } @$methods ) {
my @required_args = qw(dbh dsn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $dsn) = @args{@required_args};
$self->recurse_to_slaves(
{ dbh => $dbh,
dsn => $dsn,
callback => sub {
my ( $dsn, $dbh, $level, $parent ) = @_;
return unless $level;
PTDEBUG && _d('Found slave:', $dp->as_string($dsn));
push @$slaves, $make_cxn->(dsn => $dsn, dbh => $dbh);
return;
},
}
);
}
elsif ( $methods->[0] =~ m/^dsn=/i ) {
(my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i;
$slaves = $self->get_cxn_from_dsn_table(
%args,
dsn_table_dsn => $dsn_table_dsn,
);
}
elsif ( $methods->[0] =~ m/none/i ) {
PTDEBUG && _d('Not getting to slaves');
}
else {
die "Unexpected recursion methods: @$methods";
}
return $slaves;
}
sub _resolve_recursion_methods {
my ($self, $dsn) = @_;
my $o = $self->{OptionParser};
if ( $o->got('recursion-method') ) {
return $o->get('recursion-method');
}
elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) {
PTDEBUG && _d('Port number is non-standard; using only hosts method');
return [qw(hosts)];
}
else {
return $o->get('recursion-method');
}
}
sub recurse_to_slaves {
my ( $self, $args, $level ) = @_;
$level ||= 0;
my $dp = $self->{DSNParser};
my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse');
my $dsn = $args->{dsn};
my $methods = $self->_resolve_recursion_methods($dsn);
PTDEBUG && _d('Recursion methods:', @$methods);
if ( lc($methods->[0]) eq 'none' ) {
PTDEBUG && _d('Not recursing to slaves');
return;
}
my $dbh;
eval {
$dbh = $args->{dbh} || $dp->get_dbh(
$dp->get_cxn_params($dsn), { AutoCommit => 1 });
PTDEBUG && _d('Connected to', $dp->as_string($dsn));
};
if ( $EVAL_ERROR ) {
print STDERR "Cannot connect to ", $dp->as_string($dsn), "\n"
or die "Cannot print: $OS_ERROR";
return;
}
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
my ($id) = $dbh->selectrow_array($sql);
PTDEBUG && _d('Working on server ID', $id);
my $master_thinks_i_am = $dsn->{server_id};
if ( !defined $id
|| ( defined $master_thinks_i_am && $master_thinks_i_am != $id )
|| $args->{server_ids_seen}->{$id}++
) {
PTDEBUG && _d('Server ID seen, or not what master said');
if ( $args->{skip_callback} ) {
$args->{skip_callback}->($dsn, $dbh, $level, $args->{parent});
}
return;
}
$args->{callback}->($dsn, $dbh, $level, $args->{parent});
if ( !defined $recurse || $level < $recurse ) {
my @slaves =
grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves.
$self->find_slave_hosts($dp, $dbh, $dsn, $methods);
foreach my $slave ( @slaves ) {
PTDEBUG && _d('Recursing from',
$dp->as_string($dsn), 'to', $dp->as_string($slave));
$self->recurse_to_slaves(
{ %$args, dsn => $slave, dbh => undef, parent => $dsn }, $level + 1 );
}
}
}
sub find_slave_hosts {
my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_;
PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn),
'using methods', @$methods);
my @slaves;
METHOD:
foreach my $method ( @$methods ) {
my $find_slaves = "_find_slaves_by_$method";
PTDEBUG && _d('Finding slaves with', $find_slaves);
@slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn);
last METHOD if @slaves;
}
PTDEBUG && _d('Found', scalar(@slaves), 'slaves');
return @slaves;
}
sub _find_slaves_by_processlist {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves = map {
my $slave = $dsn_parser->parse("h=$_", $dsn);
$slave->{source} = 'processlist';
$slave;
}
grep { $_ }
map {
my ( $host ) = $_->{host} =~ m/^([^:]+):/;
if ( $host eq 'localhost' ) {
$host = '127.0.0.1'; # Replication never uses sockets.
}
$host;
} $self->get_connected_slaves($dbh);
return @slaves;
}
sub _find_slaves_by_hosts {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves;
my $sql = 'SHOW SLAVE HOSTS';
PTDEBUG && _d($dbh, $sql);
@slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })};
if ( @slaves ) {
PTDEBUG && _d('Found some SHOW SLAVE HOSTS info');
@slaves = map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
my $spec = "h=$hash{host},P=$hash{port}"
. ( $hash{user} ? ",u=$hash{user}" : '')
. ( $hash{password} ? ",p=$hash{password}" : '');
my $dsn = $dsn_parser->parse($spec, $dsn);
$dsn->{server_id} = $hash{server_id};
$dsn->{master_id} = $hash{master_id};
$dsn->{source} = 'hosts';
$dsn;
} @slaves;
}
return @slaves;
}
sub get_connected_slaves {
my ( $self, $dbh ) = @_;
my $show = "SHOW GRANTS FOR ";
my $user = 'CURRENT_USER()';
my $sql = $show . $user;
PTDEBUG && _d($dbh, $sql);
my $proc;
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
if ( $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) {
PTDEBUG && _d('Retrying SHOW GRANTS without host; error:',
$EVAL_ERROR);
($user) = split('@', $user);
$sql = $show . $user;
PTDEBUG && _d($sql);
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
}
die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR;
}
if ( !$proc ) {
die "You do not have the PROCESS privilege";
}
$sql = 'SHOW PROCESSLIST';
PTDEBUG && _d($dbh, $sql);
grep { $_->{command} =~ m/Binlog Dump/i }
map { # Lowercase the column names
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{$dbh->selectall_arrayref($sql, { Slice => {} })};
}
sub is_master_of {
my ( $self, $master, $slave ) = @_;
my $master_status = $self->get_master_status($master)
or die "The server specified as a master is not a master";
my $slave_status = $self->get_slave_status($slave)
or die "The server specified as a slave is not a slave";
my @connected = $self->get_connected_slaves($master)
or die "The server specified as a master has no connected slaves";
my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'");
if ( $port != $slave_status->{master_port} ) {
die "The slave is connected to $slave_status->{master_port} "
. "but the master's port is $port";
}
if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) {
die "I don't see any slave I/O thread connected with user "
. $slave_status->{master_user};
}
if ( ($slave_status->{slave_io_state} || '')
eq 'Waiting for master to send event' )
{
my ( $master_log_name, $master_log_num )
= $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
my ( $slave_log_name, $slave_log_num )
= $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
if ( $master_log_name ne $slave_log_name
|| abs($master_log_num - $slave_log_num) > 1 )
{
die "The slave thinks it is reading from "
. "$slave_status->{master_log_file}, but the "
. "master is writing to $master_status->{file}";
}
}
return 1;
}
sub get_master_dsn {
my ( $self, $dbh, $dsn, $dsn_parser ) = @_;
my $master = $self->get_slave_status($dbh) or return undef;
my $spec = "h=$master->{master_host},P=$master->{master_port}";
return $dsn_parser->parse($spec, $dsn);
}
sub get_slave_status {
my ( $self, $dbh ) = @_;
if ( !$self->{not_a_slave}->{$dbh} ) {
my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS}
||= $dbh->prepare('SHOW SLAVE STATUS');
PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS');
$sth->execute();
my ($ss) = @{$sth->fetchall_arrayref({})};
if ( $ss && %$ss ) {
$ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys
return $ss;
}
PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS');
$self->{not_a_slave}->{$dbh}++;
}
}
sub get_master_status {
my ( $self, $dbh ) = @_;
if ( $self->{not_a_master}->{$dbh} ) {
PTDEBUG && _d('Server on dbh', $dbh, 'is not a master');
return;
}
my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS}
||= $dbh->prepare('SHOW MASTER STATUS');
PTDEBUG && _d($dbh, 'SHOW MASTER STATUS');
$sth->execute();
my ($ms) = @{$sth->fetchall_arrayref({})};
PTDEBUG && _d(
$ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms
: '');
if ( !$ms || scalar keys %$ms < 2 ) {
PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master');
$self->{not_a_master}->{$dbh}++;
}
return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys
}
sub wait_for_master {
my ( $self, %args ) = @_;
my @required_args = qw(master_status slave_dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($master_status, $slave_dbh) = @args{@required_args};
my $timeout = $args{timeout} || 60;
my $result;
my $waited;
if ( $master_status ) {
my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', "
. "$master_status->{position}, $timeout)";
PTDEBUG && _d($slave_dbh, $sql);
my $start = time;
($result) = $slave_dbh->selectrow_array($sql);
$waited = time - $start;
PTDEBUG && _d('Result of waiting:', $result);
PTDEBUG && _d("Waited", $waited, "seconds");
}
else {
PTDEBUG && _d('Not waiting: this server is not a master');
}
return {
result => $result,
waited => $waited,
};
}
sub stop_slave {
my ( $self, $dbh ) = @_;
my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE}
||= $dbh->prepare('STOP SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
sub start_slave {
my ( $self, $dbh, $pos ) = @_;
if ( $pos ) {
my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', "
. "MASTER_LOG_POS=$pos->{position}";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
else {
my $sth = $self->{sths}->{$dbh}->{START_SLAVE}
||= $dbh->prepare('START SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
}
sub catchup_to_master {
my ( $self, $slave, $master, $timeout ) = @_;
$self->stop_slave($master);
$self->stop_slave($slave);
my $slave_status = $self->get_slave_status($slave);
my $slave_pos = $self->repl_posn($slave_status);
my $master_status = $self->get_master_status($master);
my $master_pos = $self->repl_posn($master_status);
PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
my $result;
if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) {
PTDEBUG && _d('Waiting for slave to catch up to master');
$self->start_slave($slave, $master_pos);
$result = $self->wait_for_master(
master_status => $master_status,
slave_dbh => $slave,
timeout => $timeout,
master_status => $master_status
);
if ( !defined $result->{result} ) {
$slave_status = $self->get_slave_status($slave);
if ( !$self->slave_is_running($slave_status) ) {
PTDEBUG && _d('Master position:',
$self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
$slave_pos = $self->repl_posn($slave_status);
if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) {
die "MASTER_POS_WAIT() returned NULL but slave has not "
. "caught up to master";
}
PTDEBUG && _d('Slave is caught up to master and stopped');
}
else {
die "Slave has not caught up to master and it is still running";
}
}
}
else {
PTDEBUG && _d("Slave is already caught up to master");
}
return $result;
}
sub catchup_to_same_pos {
my ( $self, $s1_dbh, $s2_dbh ) = @_;
$self->stop_slave($s1_dbh);
$self->stop_slave($s2_dbh);
my $s1_status = $self->get_slave_status($s1_dbh);
my $s2_status = $self->get_slave_status($s2_dbh);
my $s1_pos = $self->repl_posn($s1_status);
my $s2_pos = $self->repl_posn($s2_status);
if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) {
$self->start_slave($s1_dbh, $s2_pos);
}
elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) {
$self->start_slave($s2_dbh, $s1_pos);
}
$s1_status = $self->get_slave_status($s1_dbh);
$s2_status = $self->get_slave_status($s2_dbh);
$s1_pos = $self->repl_posn($s1_status);
$s2_pos = $self->repl_posn($s2_status);
if ( $self->slave_is_running($s1_status)
|| $self->slave_is_running($s2_status)
|| $self->pos_cmp($s1_pos, $s2_pos) != 0)
{
die "The servers aren't both stopped at the same position";
}
}
sub slave_is_running {
my ( $self, $slave_status ) = @_;
return ($slave_status->{slave_sql_running} || 'No') eq 'Yes';
}
sub has_slave_updates {
my ( $self, $dbh ) = @_;
my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'};
PTDEBUG && _d($dbh, $sql);
my ($name, $value) = $dbh->selectrow_array($sql);
return $value && $value =~ m/^(1|ON)$/;
}
sub repl_posn {
my ( $self, $status ) = @_;
if ( exists $status->{file} && exists $status->{position} ) {
return {
file => $status->{file},
position => $status->{position},
};
}
else {
return {
file => $status->{relay_master_log_file},
position => $status->{exec_master_log_pos},
};
}
}
sub get_slave_lag {
my ( $self, $dbh ) = @_;
my $stat = $self->get_slave_status($dbh);
return unless $stat; # server is not a slave
return $stat->{seconds_behind_master};
}
sub pos_cmp {
my ( $self, $a, $b ) = @_;
return $self->pos_to_string($a) cmp $self->pos_to_string($b);
}
sub short_host {
my ( $self, $dsn ) = @_;
my ($host, $port);
if ( $dsn->{master_host} ) {
$host = $dsn->{master_host};
$port = $dsn->{master_port};
}
else {
$host = $dsn->{h};
$port = $dsn->{P};
}
return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" );
}
sub is_replication_thread {
my ( $self, $query, %args ) = @_;
return unless $query;
my $type = lc($args{type} || 'all');
die "Invalid type: $type"
unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i;
my $match = 0;
if ( $type =~ m/binlog_dump|all/i ) {
$match = 1
if ($query->{Command} || $query->{command} || '') eq "Binlog Dump";
}
if ( !$match ) {
if ( ($query->{User} || $query->{user} || '') eq "system user" ) {
PTDEBUG && _d("Slave replication thread");
if ( $type ne 'all' ) {
my $state = $query->{State} || $query->{state} || '';
if ( $state =~ m/^init|end$/ ) {
PTDEBUG && _d("Special state:", $state);
$match = 1;
}
else {
my ($slave_sql) = $state =~ m/
^(Waiting\sfor\sthe\snext\sevent
|Reading\sevent\sfrom\sthe\srelay\slog
|Has\sread\sall\srelay\slog;\swaiting
|Making\stemp\sfile
|Waiting\sfor\sslave\smutex\son\sexit)/xi;
$match = $type eq 'slave_sql' && $slave_sql ? 1
: $type eq 'slave_io' && !$slave_sql ? 1
: 0;
}
}
else {
$match = 1;
}
}
else {
PTDEBUG && _d('Not system user');
}
if ( !defined $args{check_known_ids} || $args{check_known_ids} ) {
my $id = $query->{Id} || $query->{id};
if ( $match ) {
$self->{replication_thread}->{$id} = 1;
}
else {
if ( $self->{replication_thread}->{$id} ) {
PTDEBUG && _d("Thread ID is a known replication thread ID");
$match = 1;
}
}
}
}
PTDEBUG && _d('Matches', $type, 'replication thread:',
($match ? 'yes' : 'no'), '; match:', $match);
return $match;
}
sub get_replication_filters {
my ( $self, %args ) = @_;
my @required_args = qw(dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh) = @args{@required_args};
my %filters = ();
my $status = $self->get_master_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
binlog_do_db
binlog_ignore_db
);
}
$status = $self->get_slave_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
replicate_do_db
replicate_ignore_db
replicate_do_table
replicate_ignore_table
replicate_wild_do_table
replicate_wild_ignore_table
);
my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'";
PTDEBUG && _d($dbh, $sql);
my $row = $dbh->selectrow_arrayref($sql);
$filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF';
}
return \%filters;
}
sub pos_to_string {
my ( $self, $pos ) = @_;
my $fmt = '%s/%020d';
return sprintf($fmt, @{$pos}{qw(file position)});
}
sub reset_known_replication_threads {
my ( $self ) = @_;
$self->{replication_thread} = {};
return;
}
sub get_cxn_from_dsn_table {
my ($self, %args) = @_;
my @required_args = qw(dsn_table_dsn make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dsn_table_dsn, $make_cxn) = @args{@required_args};
PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn);
my $dp = $self->{DSNParser};
my $q = $self->{Quoter};
my $dsn = $dp->parse($dsn_table_dsn);
my $dsn_table;
if ( $dsn->{D} && $dsn->{t} ) {
$dsn_table = $q->quote($dsn->{D}, $dsn->{t});
}
elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) {
$dsn_table = $q->quote($q->split_unquote($dsn->{t}));
}
else {
die "DSN table DSN does not specify a database (D) "
. "or a database-qualified table (t)";
}
my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn);
my $dbh = $dsn_tbl_cxn->connect();
my $sql = "SELECT dsn FROM $dsn_table ORDER BY id";
PTDEBUG && _d($sql);
my $dsn_strings = $dbh->selectcol_arrayref($sql);
my @cxn;
if ( $dsn_strings ) {
foreach my $dsn_string ( @$dsn_strings ) {
PTDEBUG && _d('DSN from DSN table:', $dsn_string);
push @cxn, $make_cxn->(dsn_string => $dsn_string);
}
}
return \@cxn;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MasterSlave package
# ###########################################################################
# ###########################################################################
# OptionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/OptionParser.pm
# t/lib/OptionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OptionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
use Data::Dumper;
my $POD_link_re = '[LC]<"?([^">]+)"?>';
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
$program_name ||= $PROGRAM_NAME;
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my %attributes = (
'type' => 1,
'short form' => 1,
'group' => 1,
'default' => 1,
'cumulative' => 1,
'negatable' => 1,
);
my $self = {
head1 => 'OPTIONS', # These args are used internally
skip_rules => 0, # to instantiate another Option-
item => '--(.*)', # Parser obj that parses the
attributes => \%attributes, # DSN OPTIONS section. Tools
parse_attributes => \&_parse_attribs, # don't tinker with these args.
%args,
strict => 1, # disabled by a special rule
program_name => $program_name,
opts => {},
got_opts => 0,
short_opts => {},
defaults => {},
groups => {},
allowed_groups => {},
errors => [],
rules => [], # desc of rules for --help
mutex => [], # rule: opts are mutually exclusive
atleast1 => [], # rule: at least one opt is required
disables => {}, # rule: opt disables other opts
defaults_to => {}, # rule: opt defaults to value of other opt
DSNParser => undef,
default_files => [
"/etc/percona-toolkit/percona-toolkit.conf",
"/etc/percona-toolkit/$program_name.conf",
"$home/.percona-toolkit.conf",
"$home/.$program_name.conf",
],
types => {
string => 's', # standard Getopt type
int => 'i', # standard Getopt type
float => 'f', # standard Getopt type
Hash => 'H', # hash, formed from a comma-separated list
hash => 'h', # hash as above, but only if a value is given
Array => 'A', # array, similar to Hash
array => 'a', # array, similar to hash
DSN => 'd', # DSN
size => 'z', # size with kMG suffix (powers of 2^10)
time => 'm', # time, with an optional suffix of s/h/m/d
},
};
return bless $self, $class;
}
sub get_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
my @specs = $self->_pod_to_specs($file);
$self->_parse_specs(@specs);
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
PTDEBUG && _d('Parsing DSN OPTIONS');
my $dsn_attribs = {
dsn => 1,
copy => 1,
};
my $parse_dsn_attribs = sub {
my ( $self, $option, $attribs ) = @_;
map {
my $val = $attribs->{$_};
if ( $val ) {
$val = $val eq 'yes' ? 1
: $val eq 'no' ? 0
: $val;
$attribs->{$_} = $val;
}
} keys %$attribs;
return {
key => $option,
%$attribs,
};
};
my $dsn_o = new OptionParser(
description => 'DSN OPTIONS',
head1 => 'DSN OPTIONS',
dsn => 0, # XXX don't infinitely recurse!
item => '\* (.)', # key opts are a single character
skip_rules => 1, # no rules before opts
attributes => $dsn_attribs,
parse_attributes => $parse_dsn_attribs,
);
my @dsn_opts = map {
my $opts = {
key => $_->{spec}->{key},
dsn => $_->{spec}->{dsn},
copy => $_->{spec}->{copy},
desc => $_->{desc},
};
$opts;
} $dsn_o->_pod_to_specs($file);
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
}
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
$self->{version} = $1;
PTDEBUG && _d($self->{version});
}
return;
}
sub DSNParser {
my ( $self ) = @_;
return $self->{DSNParser};
};
sub get_defaults_files {
my ( $self ) = @_;
return @{$self->{default_files}};
}
sub _pod_to_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my @specs = ();
my @rules = ();
my $para;
local $INPUT_RECORD_SEPARATOR = '';
while ( $para = <$fh> ) {
next unless $para =~ m/^=head1 $self->{head1}/;
last;
}
while ( $para = <$fh> ) {
last if $para =~ m/^=over/;
next if $self->{skip_rules};
chomp $para;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
PTDEBUG && _d('Option rule:', $para);
push @rules, $para;
}
die "POD has no $self->{head1} section" unless $para;
do {
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
chomp $para;
PTDEBUG && _d($para);
my %attribs;
$para = <$fh>; # read next paragraph, possibly attributes
if ( $para =~ m/: / ) { # attributes
$para =~ s/\s+\Z//g;
%attribs = map {
my ( $attrib, $val) = split(/: /, $_);
die "Unrecognized attribute for --$option: $attrib"
unless $self->{attributes}->{$attrib};
($attrib, $val);
} split(/; /, $para);
if ( $attribs{'short form'} ) {
$attribs{'short form'} =~ s/-//;
}
$para = <$fh>; # read next paragraph, probably short help desc
}
else {
PTDEBUG && _d('Option has no attributes');
}
$para =~ s/\s+\Z//g;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
PTDEBUG && _d('Short help:', $para);
die "No description after option spec $option" if $para =~ m/^=item/;
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
$option = $base_option;
$attribs{'negatable'} = 1;
}
push @specs, {
spec => $self->{parse_attributes}->($self, $option, \%attribs),
desc => $para
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
};
}
while ( $para = <$fh> ) {
last unless $para;
if ( $para =~ m/^=head1/ ) {
$para = undef; # Can't 'last' out of a do {} block.
last;
}
last if $para =~ m/^=item /;
}
} while ( $para );
die "No valid specs in $self->{head1}" unless @specs;
close $fh;
return @specs, @rules;
}
sub _parse_specs {
my ( $self, @specs ) = @_;
my %disables; # special rule that requires deferred checking
foreach my $opt ( @specs ) {
if ( ref $opt ) { # It's an option spec, not a rule.
PTDEBUG && _d('Parsing opt spec:',
map { ($_, '=>', $opt->{$_}) } keys %$opt);
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
if ( !$long ) {
die "Cannot parse long option from spec $opt->{spec}";
}
$opt->{long} = $long;
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
$self->{opts}->{$long} = $opt;
if ( length $long == 1 ) {
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
$self->{short_opts}->{$long} = $long;
}
if ( $short ) {
die "Duplicate short option -$short"
if exists $self->{short_opts}->{$short};
$self->{short_opts}->{$short} = $long;
$opt->{short} = $short;
}
else {
$opt->{short} = undef;
}
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
$opt->{group} ||= 'default';
$self->{groups}->{ $opt->{group} }->{$long} = 1;
$opt->{value} = undef;
$opt->{got} = 0;
my ( $type ) = $opt->{spec} =~ m/=(.)/;
$opt->{type} = $type;
PTDEBUG && _d($long, 'type:', $type);
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
$self->{defaults}->{$long} = defined $def ? $def : 1;
PTDEBUG && _d($long, 'default:', $def);
}
if ( $long eq 'config' ) {
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
}
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
$disables{$long} = $dis;
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
PTDEBUG && _d('Parsing rule:', $opt);
push @{$self->{rules}}, $opt;
my @participants = $self->_get_participants($opt);
my $rule_ok = 0;
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
$rule_ok = 1;
push @{$self->{mutex}}, \@participants;
PTDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
PTDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
}
if ( $opt =~ m/restricted to option groups/ ) {
$rule_ok = 1;
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
my @groups = split(',', $groups);
%{$self->{allowed_groups}->{$participants[0]}} = map {
s/\s+//;
$_ => 1;
} @groups;
}
if( $opt =~ m/accepts additional command-line arguments/ ) {
$rule_ok = 1;
$self->{strict} = 0;
PTDEBUG && _d("Strict mode disabled by rule");
}
die "Unrecognized option rule: $opt" unless $rule_ok;
}
}
foreach my $long ( keys %disables ) {
my @participants = $self->_get_participants($disables{$long});
$self->{disables}->{$long} = \@participants;
PTDEBUG && _d('Option', $long, 'disables', @participants);
}
return;
}
sub _get_participants {
my ( $self, $str ) = @_;
my @participants;
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
die "Option --$long does not exist while processing rule $str"
unless exists $self->{opts}->{$long};
push @participants, $long;
}
PTDEBUG && _d('Participants for', $str, ':', @participants);
return @participants;
}
sub opts {
my ( $self ) = @_;
my %opts = %{$self->{opts}};
return %opts;
}
sub short_opts {
my ( $self ) = @_;
my %short_opts = %{$self->{short_opts}};
return %short_opts;
}
sub set_defaults {
my ( $self, %defaults ) = @_;
$self->{defaults} = {};
foreach my $long ( keys %defaults ) {
die "Cannot set default for nonexistent option $long"
unless exists $self->{opts}->{$long};
$self->{defaults}->{$long} = $defaults{$long};
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
}
return;
}
sub get_defaults {
my ( $self ) = @_;
return $self->{defaults};
}
sub get_groups {
my ( $self ) = @_;
return $self->{groups};
}
sub _set_option {
my ( $self, $opt, $val ) = @_;
my $long = exists $self->{opts}->{$opt} ? $opt
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
: die "Getopt::Long gave a nonexistent option: $opt";
$opt = $self->{opts}->{$long};
if ( $opt->{is_cumulative} ) {
$opt->{value}++;
}
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
my $next_opt = $1;
if ( exists $self->{opts}->{$next_opt}
|| exists $self->{short_opts}->{$next_opt} ) {
$self->save_error("--$long requires a string value");
return;
}
else {
$opt->{value} = $val;
}
}
else {
$opt->{value} = $val;
}
$opt->{got} = 1;
PTDEBUG && _d('Got option', $long, '=', $val);
}
sub get_opts {
my ( $self ) = @_;
foreach my $long ( keys %{$self->{opts}} ) {
$self->{opts}->{$long}->{got} = 0;
$self->{opts}->{$long}->{value}
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
: $self->{opts}->{$long}->{is_cumulative} ? 0
: undef;
}
$self->{got_opts} = 0;
$self->{errors} = [];
if ( @ARGV && $ARGV[0] eq "--config" ) {
shift @ARGV;
$self->_set_option('config', shift @ARGV);
}
if ( $self->has('config') ) {
my @extra_args;
foreach my $filename ( split(',', $self->get('config')) ) {
eval {
push @extra_args, $self->_read_config_file($filename);
};
if ( $EVAL_ERROR ) {
if ( $self->got('config') ) {
die $EVAL_ERROR;
}
elsif ( PTDEBUG ) {
_d($EVAL_ERROR);
}
}
}
unshift @ARGV, @extra_args;
}
Getopt::Long::Configure('no_ignore_case', 'bundling');
GetOptions(
map { $_->{spec} => sub { $self->_set_option(@_); } }
grep { $_->{long} ne 'config' } # --config is handled specially above.
values %{$self->{opts}}
) or $self->save_error('Error parsing options');
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
if ( $self->{version} ) {
print $self->{version}, "\n";
}
else {
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
}
exit 1;
}
if ( @ARGV && $self->{strict} ) {
$self->save_error("Unrecognized command-line options @ARGV");
}
foreach my $mutex ( @{$self->{mutex}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
if ( @set > 1 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
. ' are mutually exclusive.';
$self->save_error($err);
}
}
foreach my $required ( @{$self->{atleast1}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
if ( @set == 0 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$required}[ 0 .. scalar(@$required) - 2] )
.' or --'.$self->{opts}->{$required->[-1]}->{long};
$self->save_error("Specify at least one of $err");
}
}
$self->_check_opts( keys %{$self->{opts}} );
$self->{got_opts} = 1;
return;
}
sub _check_opts {
my ( $self, @long ) = @_;
my $long_last = scalar @long;
while ( @long ) {
foreach my $i ( 0..$#long ) {
my $long = $long[$i];
next unless $long;
my $opt = $self->{opts}->{$long};
if ( $opt->{got} ) {
if ( exists $self->{disables}->{$long} ) {
my @disable_opts = @{$self->{disables}->{$long}};
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
PTDEBUG && _d('Unset options', @disable_opts,
'because', $long,'disables them');
}
if ( exists $self->{allowed_groups}->{$long} ) {
my @restricted_groups = grep {
!exists $self->{allowed_groups}->{$long}->{$_}
} keys %{$self->{groups}};
my @restricted_opts;
foreach my $restricted_group ( @restricted_groups ) {
RESTRICTED_OPT:
foreach my $restricted_opt (
keys %{$self->{groups}->{$restricted_group}} )
{
next RESTRICTED_OPT if $restricted_opt eq $long;
push @restricted_opts, $restricted_opt
if $self->{opts}->{$restricted_opt}->{got};
}
}
if ( @restricted_opts ) {
my $err;
if ( @restricted_opts == 1 ) {
$err = "--$restricted_opts[0]";
}
else {
$err = join(', ',
map { "--$self->{opts}->{$_}->{long}" }
grep { $_ }
@restricted_opts[0..scalar(@restricted_opts) - 2]
)
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
}
$self->save_error("--$long is not allowed with $err");
}
}
}
elsif ( $opt->{is_required} ) {
$self->save_error("Required option --$long must be specified");
}
$self->_validate_type($opt);
if ( $opt->{parsed} ) {
delete $long[$i];
}
else {
PTDEBUG && _d('Temporarily failed to parse', $long);
}
}
die "Failed to parse options, possibly due to circular dependencies"
if @long == $long_last;
$long_last = @long;
}
return;
}
sub _validate_type {
my ( $self, $opt ) = @_;
return unless $opt;
if ( !$opt->{type} ) {
$opt->{parsed} = 1;
return;
}
my $val = $opt->{value};
if ( $val && $opt->{type} eq 'm' ) { # type time
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
if ( !$suffix ) {
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
$suffix = $s || 's';
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
$opt->{long}, '(value:', $val, ')');
}
if ( $suffix =~ m/[smhd]/ ) {
$val = $suffix eq 's' ? $num # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$opt->{value} = ($prefix || '') . $val;
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
}
else {
$self->save_error("Invalid time suffix for --$opt->{long}");
}
}
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
$from_key, 'parsed');
return;
}
}
my $defaults = $self->{DSNParser}->parse_options($self);
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
}
elsif ( $val && $opt->{type} eq 'z' ) { # type size
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
$self->_parse_size($opt, $val);
}
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
$opt->{value} = { map { $_ => 1 } split(/(?{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
$opt->{value} = [ split(/(?{long}, 'type', $opt->{type}, 'value', $val);
}
$opt->{parsed} = 1;
return;
}
sub get {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{value};
}
sub got {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{got};
}
sub has {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
return defined $long ? exists $self->{opts}->{$long} : 0;
}
sub set {
my ( $self, $opt, $val ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
$self->{opts}->{$long}->{value} = $val;
return;
}
sub save_error {
my ( $self, $error ) = @_;
push @{$self->{errors}}, $error;
return;
}
sub errors {
my ( $self ) = @_;
return $self->{errors};
}
sub usage {
my ( $self ) = @_;
warn "No usage string is set" unless $self->{usage}; # XXX
return "Usage: " . ($self->{usage} || '') . "\n";
}
sub descr {
my ( $self ) = @_;
warn "No description string is set" unless $self->{description}; # XXX
my $descr = ($self->{description} || $self->{program_name} || '')
. " For more details, please use the --help option, "
. "or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation.";
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
unless $ENV{DONT_BREAK_LINES};
$descr =~ s/ +$//mg;
return $descr;
}
sub usage_or_errors {
my ( $self, $file, $return ) = @_;
$file ||= $self->{file} || __FILE__;
if ( !$self->{description} || !$self->{usage} ) {
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
PTDEBUG && _d("Description:", $self->{description},
"\nUsage:", $self->{usage});
}
if ( $self->{opts}->{help}->{got} ) {
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
exit 0 unless $return;
}
elsif ( scalar @{$self->{errors}} ) {
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
exit 1 unless $return;
}
return;
}
sub print_errors {
my ( $self ) = @_;
my $usage = $self->usage() . "\n";
if ( (my @errors = @{$self->{errors}}) ) {
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
. "\n";
}
return $usage . "\n" . $self->descr();
}
sub print_usage {
my ( $self ) = @_;
die "Run get_opts() before print_usage()" unless $self->{got_opts};
my @opts = values %{$self->{opts}};
my $maxl = max(
map {
length($_->{long}) # option long name
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
}
@opts);
my $maxs = max(0,
map {
length($_)
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
}
values %{$self->{short_opts}});
my $lcol = max($maxl, ($maxs + 3));
my $rcol = 80 - $lcol - 6;
my $rpad = ' ' x ( 80 - $rcol );
$maxs = max($lcol - 3, $maxs);
my $usage = $self->descr() . "\n" . $self->usage();
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
push @groups, 'default';
foreach my $group ( reverse @groups ) {
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
foreach my $opt (
sort { $a->{long} cmp $b->{long} }
grep { $_->{group} eq $group }
@opts )
{
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
my $short = $opt->{short};
my $desc = $opt->{desc};
$long .= $opt->{type} ? "=$opt->{type}" : "";
if ( $opt->{type} && $opt->{type} eq 'm' ) {
my ($s) = $desc =~ m/\(suffix (.)\)/;
$s ||= 's';
$desc =~ s/\s+\(suffix .\)//;
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
. "d=days; if no suffix, $s is used.";
}
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
$desc =~ s/ +$//mg;
if ( $short ) {
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
}
else {
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
}
}
}
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
if ( (my @rules = @{$self->{rules}}) ) {
$usage .= "\nRules:\n\n";
$usage .= join("\n", map { " $_" } @rules) . "\n";
}
if ( $self->{DSNParser} ) {
$usage .= "\n" . $self->{DSNParser}->usage();
}
$usage .= "\nOptions and values after processing arguments:\n\n";
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
my $val = $opt->{value};
my $type = $opt->{type} || '';
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
: !defined $val ? '(No value)'
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
: $type =~ m/H|h/ ? join(',', sort keys %$val)
: $type =~ m/A|a/ ? join(',', @$val)
: $val;
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
}
return $usage;
}
sub prompt_noecho {
shift @_ if ref $_[0] eq __PACKAGE__;
my ( $prompt ) = @_;
local $OUTPUT_AUTOFLUSH = 1;
print STDERR $prompt
or die "Cannot print: $OS_ERROR";
my $response;
eval {
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
chomp($response = );
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# Daemon package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Daemon.pm
# t/lib/Daemon.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Daemon;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(setsid);
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(o) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $o = $args{o};
my $self = {
o => $o,
log_file => $o->has('log') ? $o->get('log') : undef,
PID_file => $o->has('pid') ? $o->get('pid') : undef,
};
check_PID_file(undef, $self->{PID_file});
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
return bless $self, $class;
}
sub daemonize {
my ( $self ) = @_;
PTDEBUG && _d('About to fork and daemonize');
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $pid ) {
PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
exit;
}
PTDEBUG && _d('Daemonizing child PID', $PID);
$self->{PID_owner} = $PID;
$self->{child} = 1;
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
$self->_make_PID_file();
$OUTPUT_AUTOFLUSH = 1;
PTDEBUG && _d('Redirecting STDIN to /dev/null');
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
if ( $self->{log_file} ) {
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
close STDOUT;
open STDOUT, '>>', $self->{log_file}
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
close STDERR;
open STDERR, ">&STDOUT"
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
}
else {
if ( -t STDOUT ) {
PTDEBUG && _d('No log file and STDOUT is a terminal;',
'redirecting to /dev/null');
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
PTDEBUG && _d('No log file and STDERR is a terminal;',
'redirecting to /dev/null');
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
return;
}
sub check_PID_file {
my ( $self, $file ) = @_;
my $PID_file = $self ? $self->{PID_file} : $file;
PTDEBUG && _d('Checking PID file', $PID_file);
if ( $PID_file && -f $PID_file ) {
my $pid;
eval {
chomp($pid = (slurp_file($PID_file) || ''));
};
if ( $EVAL_ERROR ) {
die "The PID file $PID_file already exists but it cannot be read: "
. $EVAL_ERROR;
}
PTDEBUG && _d('PID file exists; it contains PID', $pid);
if ( $pid ) {
my $pid_is_alive = kill 0, $pid;
if ( $pid_is_alive ) {
die "The PID file $PID_file already exists "
. " and the PID that it contains, $pid, is running";
}
else {
warn "Overwriting PID file $PID_file because the PID that it "
. "contains, $pid, is not running";
}
}
else {
die "The PID file $PID_file already exists but it does not "
. "contain a PID";
}
}
else {
PTDEBUG && _d('No PID file');
}
return;
}
sub make_PID_file {
my ( $self ) = @_;
if ( exists $self->{child} ) {
die "Do not call Daemon::make_PID_file() for daemonized scripts";
}
$self->_make_PID_file();
$self->{PID_owner} = $PID;
return;
}
sub _make_PID_file {
my ( $self ) = @_;
my $PID_file = $self->{PID_file};
if ( !$PID_file ) {
PTDEBUG && _d('No PID file to create');
return;
}
$self->check_PID_file();
open my $PID_FH, '>', $PID_file
or die "Cannot open PID file $PID_file: $OS_ERROR";
print $PID_FH $PID
or die "Cannot print to PID file $PID_file: $OS_ERROR";
close $PID_FH
or die "Cannot close PID file $PID_file: $OS_ERROR";
PTDEBUG && _d('Created PID file:', $self->{PID_file});
return;
}
sub _remove_PID_file {
my ( $self ) = @_;
if ( $self->{PID_file} && -f $self->{PID_file} ) {
unlink $self->{PID_file}
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
PTDEBUG && _d('Removed PID file');
}
else {
PTDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ( $self ) = @_;
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
return;
}
sub slurp_file {
my ($file) = @_;
return unless $file;
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
return do { local $/; <$fh> };
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Daemon package
# ###########################################################################
# ###########################################################################
# Quoter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Quoter.pm
# t/lib/Quoter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Quoter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
return bless {}, $class;
}
sub quote {
my ( $self, @vals ) = @_;
foreach my $val ( @vals ) {
$val =~ s/`/``/g;
}
return join('.', map { '`' . $_ . '`' } @vals);
}
sub quote_val {
my ( $self, $val, %args ) = @_;
return 'NULL' unless defined $val; # undef = NULL
return "''" if $val eq ''; # blank string = ''
return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
&& !$args{is_char}; # unless is_char is true
$val =~ s/(['\\])/\\$1/g;
return "'$val'";
}
sub split_unquote {
my ( $self, $db_tbl, $default_db ) = @_;
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
for ($db, $tbl) {
next unless $_;
s/\A`//;
s/`\z//;
s/``/`/g;
}
return ($db, $tbl);
}
sub literal_like {
my ( $self, $like ) = @_;
return unless $like;
$like =~ s/([%_])/\\$1/g;
return "'$like'";
}
sub join_quote {
my ( $self, $default_db, $db_tbl ) = @_;
return unless $db_tbl;
my ($db, $tbl) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
$db = "`$db`" if $db && $db !~ m/^`/;
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
return $db ? "$db.$tbl" : $tbl;
}
sub serialize_list {
my ( $self, @args ) = @_;
PTDEBUG && _d('Serializing', Dumper(\@args));
return unless @args;
my @parts;
foreach my $arg ( @args ) {
if ( defined $arg ) {
$arg =~ s/,/\\,/g; # escape commas
$arg =~ s/\\N/\\\\N/g; # escape literal \N
push @parts, $arg;
}
else {
push @parts, '\N';
}
}
my $string = join(',', @parts);
PTDEBUG && _d('Serialized: <', $string, '>');
return $string;
}
sub deserialize_list {
my ( $self, $string ) = @_;
PTDEBUG && _d('Deserializing <', $string, '>');
die "Cannot deserialize an undefined string" unless defined $string;
my @parts;
foreach my $arg ( split(/(? 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
local $EVAL_ERROR;
eval {
require Quoter;
};
sub new {
my ( $class, %args ) = @_;
my $self = { %args };
$self->{Quoter} ||= Quoter->new();
return bless $self, $class;
}
sub Quoter { shift->{Quoter} }
sub get_create_table {
my ( $self, $dbh, $db, $tbl ) = @_;
die "I need a dbh parameter" unless $dbh;
die "I need a db parameter" unless $db;
die "I need a tbl parameter" unless $tbl;
my $q = $self->{Quoter};
my $new_sql_mode
= q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, }
. q{@@SQL_MODE := '', }
. q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, }
. q{@@SQL_QUOTE_SHOW_CREATE := 1 */};
my $old_sql_mode
= q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, }
. q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */};
PTDEBUG && _d($new_sql_mode);
eval { $dbh->do($new_sql_mode); };
PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
my $use_sql = 'USE ' . $q->quote($db);
PTDEBUG && _d($dbh, $use_sql);
$dbh->do($use_sql);
my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
PTDEBUG && _d($show_sql);
my $href;
eval { $href = $dbh->selectrow_hashref($show_sql); };
if ( my $e = $EVAL_ERROR ) {
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
die $e;
}
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
my ($key) = grep { m/create (?:table|view)/i } keys %$href;
if ( !$key ) {
die "Error: no 'Create Table' or 'Create View' in result set from "
. "$show_sql: " . Dumper($href);
}
return $href->{$key};
}
sub parse {
my ( $self, $ddl, $opts ) = @_;
return unless $ddl;
if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
$ddl = $self->ansi_to_legacy($ddl);
}
elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
die "TableParser doesn't handle CREATE TABLE without quoting.";
}
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
$ddl =~ s/(`[^`]+`)/\L$1/g;
my $engine = $self->get_engine($ddl);
my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
PTDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
my %def_for;
@def_for{@cols} = @defs;
my (@nums, @null);
my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
foreach my $col ( @cols ) {
my $def = $def_for{$col};
$def =~ s/``//g;
my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
die "Can't determine column type for $def" unless $type;
$type_for{$col} = $type;
if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
push @nums, $col;
$is_numeric{$col} = 1;
}
if ( $def !~ m/NOT NULL/ ) {
push @null, $col;
$is_nullable{$col} = 1;
}
$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
}
my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
return {
name => $name,
cols => \@cols,
col_posn => { map { $cols[$_] => $_ } 0..$#cols },
is_col => { map { $_ => 1 } @cols },
null_cols => \@null,
is_nullable => \%is_nullable,
is_autoinc => \%is_autoinc,
clustered_key => $clustered_key,
keys => $keys,
defs => \%def_for,
numeric_cols => \@nums,
is_numeric => \%is_numeric,
engine => $engine,
type_for => \%type_for,
charset => $charset,
};
}
sub sort_indexes {
my ( $self, $tbl ) = @_;
my @indexes
= sort {
(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
|| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
|| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
|| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
}
grep {
$tbl->{keys}->{$_}->{type} eq 'BTREE'
}
sort keys %{$tbl->{keys}};
PTDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
return @indexes;
}
sub find_best_index {
my ( $self, $tbl, $index ) = @_;
my $best;
if ( $index ) {
($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
}
if ( !$best ) {
if ( $index ) {
die "Index '$index' does not exist in table";
}
else {
($best) = $self->sort_indexes($tbl);
}
}
PTDEBUG && _d('Best index found is', $best);
return $best;
}
sub find_possible_keys {
my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
return () unless $where;
my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
. ' WHERE ' . $where;
PTDEBUG && _d($sql);
my $expl = $dbh->selectrow_hashref($sql);
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
if ( $expl->{possible_keys} ) {
PTDEBUG && _d('possible_keys =', $expl->{possible_keys});
my @candidates = split(',', $expl->{possible_keys});
my %possible = map { $_ => 1 } @candidates;
if ( $expl->{key} ) {
PTDEBUG && _d('MySQL chose', $expl->{key});
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
PTDEBUG && _d('Before deduping:', join(', ', @candidates));
my %seen;
@candidates = grep { !$seen{$_}++ } @candidates;
}
PTDEBUG && _d('Final list:', join(', ', @candidates));
return @candidates;
}
else {
PTDEBUG && _d('No keys in possible_keys');
return ();
}
}
sub check_table {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl) = @args{@required_args};
my $q = $self->{Quoter} || 'Quoter';
my $db_tbl = $q->quote($db, $tbl);
PTDEBUG && _d('Checking', $db_tbl);
my $sql = "SHOW TABLES FROM " . $q->quote($db)
. ' LIKE ' . $q->literal_like($tbl);
PTDEBUG && _d($sql);
my $row;
eval {
$row = $dbh->selectrow_arrayref($sql);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
return 0;
}
if ( !$row->[0] || $row->[0] ne $tbl ) {
PTDEBUG && _d('Table does not exist');
return 0;
}
PTDEBUG && _d('Table', $db, $tbl, 'exists');
return 1;
}
sub get_engine {
my ( $self, $ddl, $opts ) = @_;
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
PTDEBUG && _d('Storage engine:', $engine);
return $engine || undef;
}
sub get_keys {
my ( $self, $ddl, $opts, $is_nullable ) = @_;
my $engine = $self->get_engine($ddl);
my $keys = {};
my $clustered_key = undef;
KEY:
foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
next KEY if $key =~ m/FOREIGN/;
my $key_ddl = $key;
PTDEBUG && _d('Parsed key:', $key_ddl);
if ( !$engine || $engine !~ m/MEMORY|HEAP/ ) {
$key =~ s/USING HASH/USING BTREE/;
}
my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
$type = $type || $special || 'BTREE';
my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
my @cols;
my @col_prefixes;
foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
push @cols, $name;
push @col_prefixes, $prefix;
}
$name =~ s/`//g;
PTDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
$keys->{$name} = {
name => $name,
type => $type,
colnames => $cols,
cols => \@cols,
col_prefixes => \@col_prefixes,
is_unique => $unique,
is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
is_col => { map { $_ => 1 } @cols },
ddl => $key_ddl,
};
if ( ($engine || '') =~ m/InnoDB/i && !$clustered_key ) {
my $this_key = $keys->{$name};
if ( $this_key->{name} eq 'PRIMARY' ) {
$clustered_key = 'PRIMARY';
}
elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
$clustered_key = $this_key->{name};
}
PTDEBUG && $clustered_key && _d('This key is the clustered key');
}
}
return $keys, $clustered_key;
}
sub get_fks {
my ( $self, $ddl, $opts ) = @_;
my $q = $self->{Quoter};
my $fks = {};
foreach my $fk (
$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
{
my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
my ($db, $tbl) = $q->split_unquote($parent, $opts->{database});
my %parent_tbl = (tbl => $tbl);
$parent_tbl{db} = $db if $db;
if ( $parent !~ m/\./ && $opts->{database} ) {
$parent = $q->quote($opts->{database}) . ".$parent";
}
$fks->{$name} = {
name => $name,
colnames => $cols,
cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
parent_tbl => \%parent_tbl,
parent_tblname => $parent,
parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
parent_colnames=> $parent_cols,
ddl => $fk,
};
}
return $fks;
}
sub remove_auto_increment {
my ( $self, $ddl ) = @_;
$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
return $ddl;
}
sub get_table_status {
my ( $self, $dbh, $db, $like ) = @_;
my $q = $self->{Quoter};
my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
PTDEBUG && _d($sql, @params);
my $sth = $dbh->prepare($sql);
eval { $sth->execute(@params); };
if ($EVAL_ERROR) {
PTDEBUG && _d($EVAL_ERROR);
return;
}
my @tables = @{$sth->fetchall_arrayref({})};
@tables = map {
my %tbl; # Make a copy with lowercased keys
@tbl{ map { lc $_ } keys %$_ } = values %$_;
$tbl{engine} ||= $tbl{type} || $tbl{comment};
delete $tbl{type};
\%tbl;
} @tables;
return @tables;
}
my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx;
sub ansi_to_legacy {
my ($self, $ddl) = @_;
$ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge;
return $ddl;
}
sub ansi_quote_replace {
my ($val) = @_;
$val =~ s/^"|"$//g;
$val =~ s/`/``/g;
$val =~ s/""/"/g;
return "`$val`";
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TableParser package
# ###########################################################################
# ###########################################################################
# Retry package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Retry.pm
# t/lib/Retry.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Retry;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::HiRes qw(sleep);
sub new {
my ( $class, %args ) = @_;
my $self = {
%args,
};
return bless $self, $class;
}
sub retry {
my ( $self, %args ) = @_;
my @required_args = qw(try fail final_fail);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($try, $fail, $final_fail) = @args{@required_args};
my $wait = $args{wait} || sub { sleep 1; };
my $tries = $args{tries} || 3;
my $last_error;
my $tryno = 0;
TRY:
while ( ++$tryno <= $tries ) {
PTDEBUG && _d("Try", $tryno, "of", $tries);
my $result;
eval {
$result = $try->(tryno=>$tryno);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d("Try code failed:", $EVAL_ERROR);
$last_error = $EVAL_ERROR;
if ( $tryno < $tries ) { # more retries
my $retry = $fail->(tryno=>$tryno, error=>$last_error);
last TRY unless $retry;
PTDEBUG && _d("Calling wait code");
$wait->(tryno=>$tryno);
}
}
else {
PTDEBUG && _d("Try code succeeded");
return $result;
}
}
PTDEBUG && _d('Try code did not succeed');
return $final_fail->(error=>$last_error);
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Retry package
# ###########################################################################
# ###########################################################################
# Transformers package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Transformers.pm
# t/lib/Transformers.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Transformers;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::Local qw(timegm timelocal);
use Digest::MD5 qw(md5_hex);
use B qw();
BEGIN {
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT = ();
our @EXPORT_OK = qw(
micro_t
percentage_of
secs_to_time
time_to_secs
shorten
ts
parse_timestamp
unix_timestamp
any_unix_timestamp
make_checksum
crc32
encode_json
);
}
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
sub micro_t {
my ( $t, %args ) = @_;
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
my $f;
$t = 0 if $t < 0;
$t = sprintf('%.17f', $t) if $t =~ /e/;
$t =~ s/\.(\d{1,6})\d*/\.$1/;
if ($t > 0 && $t <= 0.000999) {
$f = ($t * 1000000) . 'us';
}
elsif ($t >= 0.001000 && $t <= 0.999999) {
$f = sprintf("%.${p_ms}f", $t * 1000);
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
}
elsif ($t >= 1) {
$f = sprintf("%.${p_s}f", $t);
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
}
else {
$f = 0; # $t should = 0 at this point
}
return $f;
}
sub percentage_of {
my ( $is, $of, %args ) = @_;
my $p = $args{p} || 0; # float precision
my $fmt = $p ? "%.${p}f" : "%d";
return sprintf $fmt, ($is * 100) / ($of ||= 1);
}
sub secs_to_time {
my ( $secs, $fmt ) = @_;
$secs ||= 0;
return '00:00' unless $secs;
$fmt ||= $secs >= 86_400 ? 'd'
: $secs >= 3_600 ? 'h'
: 'm';
return
$fmt eq 'd' ? sprintf(
"%d+%02d:%02d:%02d",
int($secs / 86_400),
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: $fmt eq 'h' ? sprintf(
"%02d:%02d:%02d",
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: sprintf(
"%02d:%02d",
int(($secs % 3_600) / 60),
$secs % 60);
}
sub time_to_secs {
my ( $val, $default_suffix ) = @_;
die "I need a val argument" unless defined $val;
my $t = 0;
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
$suffix = $suffix || $default_suffix || 's';
if ( $suffix =~ m/[smhd]/ ) {
$t = $suffix eq 's' ? $num * 1 # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$t *= -1 if $prefix && $prefix eq '-';
}
else {
die "Invalid suffix for $val: $suffix";
}
return $t;
}
sub shorten {
my ( $num, %args ) = @_;
my $p = defined $args{p} ? $args{p} : 2; # float precision
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
my $n = 0;
my @units = ('', qw(k M G T P E Z Y));
while ( $num >= $d && $n < @units - 1 ) {
$num /= $d;
++$n;
}
return sprintf(
$num =~ m/\./ || $n
? "%.${p}f%s"
: '%d',
$num, $units[$n]);
}
sub ts {
my ( $time, $gmt ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= $gmt ? gmtime($time) : localtime($time);
$mon += 1;
$year += 1900;
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
$us = sprintf("%.6f", $us);
$us =~ s/^0\././;
$val .= $us;
}
return $val;
}
sub parse_timestamp {
my ( $val ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $f)
= $val =~ m/^$mysql_ts$/ )
{
return sprintf "%d-%02d-%02d %02d:%02d:"
. (defined $f ? '%09.6f' : '%02d'),
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
}
elsif ( $val =~ m/^$proper_ts$/ ) {
return $val;
}
return $val;
}
sub unix_timestamp {
my ( $val, $gmt ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
$val = $gmt
? timegm($s, $i, $h, $d, $m - 1, $y)
: timelocal($s, $i, $h, $d, $m - 1, $y);
if ( defined $us ) {
$us = sprintf('%.6f', $us);
$us =~ s/^0\././;
$val .= $us;
}
}
return $val;
}
sub any_unix_timestamp {
my ( $val, $callback ) = @_;
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
$n = $suffix eq 's' ? $n # Seconds
: $suffix eq 'm' ? $n * 60 # Minutes
: $suffix eq 'h' ? $n * 3600 # Hours
: $suffix eq 'd' ? $n * 86400 # Days
: $n; # default: Seconds
PTDEBUG && _d('ts is now - N[shmd]:', $n);
return time - $n;
}
elsif ( $val =~ m/^\d{9,}/ ) {
PTDEBUG && _d('ts is already a unix timestamp');
return $val;
}
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
PTDEBUG && _d('ts is MySQL slow log timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp(parse_timestamp($val));
}
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
PTDEBUG && _d('ts is properly formatted timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp($val);
}
else {
PTDEBUG && _d('ts is MySQL expression');
return $callback->($val) if $callback && ref $callback eq 'CODE';
}
PTDEBUG && _d('Unknown ts type:', $val);
return;
}
sub make_checksum {
my ( $val ) = @_;
my $checksum = uc substr(md5_hex($val), -16);
PTDEBUG && _d($checksum, 'checksum for', $val);
return $checksum;
}
sub crc32 {
my ( $string ) = @_;
return unless $string;
my $poly = 0xEDB88320;
my $crc = 0xFFFFFFFF;
foreach my $char ( split(//, $string) ) {
my $comp = ($crc ^ ord($char)) & 0xFF;
for ( 1 .. 8 ) {
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
}
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
}
return $crc ^ 0xFFFFFFFF;
}
my $got_json = eval { require JSON };
sub encode_json {
return JSON::encode_json(@_) if $got_json;
my ( $data ) = @_;
return (object_to_json($data) || '');
}
sub object_to_json {
my ($obj) = @_;
my $type = ref($obj);
if($type eq 'HASH'){
return hash_to_json($obj);
}
elsif($type eq 'ARRAY'){
return array_to_json($obj);
}
else {
return value_to_json($obj);
}
}
sub hash_to_json {
my ($obj) = @_;
my @res;
for my $k ( sort { $a cmp $b } keys %$obj ) {
push @res, string_to_json( $k )
. ":"
. ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
}
return '{' . ( @res ? join( ",", @res ) : '' ) . '}';
}
sub array_to_json {
my ($obj) = @_;
my @res;
for my $v (@$obj) {
push @res, object_to_json($v) || value_to_json($v);
}
return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
}
sub value_to_json {
my ($value) = @_;
return 'null' if(!defined $value);
my $b_obj = B::svref_2object(\$value); # for round trip problem
my $flags = $b_obj->FLAGS;
return $value # as is
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
my $type = ref($value);
if( !$type ) {
return string_to_json($value);
}
else {
return 'null';
}
}
my %esc = (
"\n" => '\n',
"\r" => '\r',
"\t" => '\t',
"\f" => '\f',
"\b" => '\b',
"\"" => '\"',
"\\" => '\\\\',
"\'" => '\\\'',
);
sub string_to_json {
my ($arg) = @_;
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g;
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
utf8::upgrade($arg);
utf8::encode($arg);
return '"' . $arg . '"';
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Transformers package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
{
my $file = 'percona-version-check';
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => md5_hex( hostname() ),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
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}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_heartbeat;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use List::Util qw(min max sum);
use Time::HiRes qw(gettimeofday time sleep usleep);
use IO::File;
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
Transformers->import(qw(ts unix_timestamp));
my @dbhs; # Holds slave DBHs if --recurse
my @sths; # Holds [$host, $sth] if --recurse
sub main {
local @ARGV = @_; # set global ARGV for this package
# Reset all global vars between test runs else weird things happen.
@dbhs = ();
@sths = ();
# ########################################################################
# Get configuration information.
# ########################################################################
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser;
$dp->prop('dbidriver', $o->get('dbi-driver'));
$dp->prop('set-vars', $o->set_vars());
if ( !$o->get('help') ) {
my @frames = $o->get('frames') =~ m/(\d+[smhd])/g;
if ( @frames ) {
my @times;
foreach my $frame ( @frames ) {
my ($num, $suf) = $frame =~ m/(\d+)([smhd])$/;
if ( !$num ) {
$o->save_error("Invalid --frames argument");
}
else {
push @times,
$suf eq 's' ? $num # Seconds
: $suf eq 'm' ? $num * 60 # Minutes
: $suf eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
}
}
$o->set('frames', \@times);
}
else {
$o->save_error("Invalid --frames argument");
}
if ( $o->get('create-table')
&& !($o->get('database') && $o->get('table'))) {
$o->save_error('--create-table requires both --database and --table');
}
if ( $o->get('interval') < 0.01 ) {
$o->save_error("--interval must be >= 0.01");
}
if ( !$o->get('stop') && !$o->get('database') ) {
$o->save_error('--database must be specified');
}
}
eval {
MasterSlave::check_recursion_method($o->get('recursion-method'));
};
if ( $EVAL_ERROR ) {
$o->save_error("Invalid --recursion-method: $EVAL_ERROR")
}
$o->usage_or_errors();
# ########################################################################
# Make common modules and var for frequently used options.
# ########################################################################
my $q = new Quoter();
my $tp = new TableParser(Quoter => $q);
my $interval = $o->get('interval');
my $skew = $o->get('update') ? 0 : $o->get('skew');
my $sentinel = $o->get('sentinel');
my $frames = $o->get('frames');
my $db = $o->get('database');
my $tbl = $o->get('table');
# ########################################################################
# Create --sentinel file if --stop was given, and possibly exit.
# ########################################################################
if ( $o->get('stop') ) {
PTDEBUG && _d('Creating sentinel file', $sentinel);
my $file = IO::File->new($sentinel, ">>")
or die "Cannot open $sentinel: $OS_ERROR\n";
print $file "Remove this file to permit pt-heartbeat to run\n"
or die "Cannot write to $sentinel: $OS_ERROR\n";
close $file
or die "Cannot close $sentinel: $OS_ERROR\n";
print STDOUT "Successfully created file $sentinel\n";
# Exit only if no other action (update, monitor, check) is given.
if ( !$o->get('update') && !$o->get('check') && !$o->get('monitor') ) {
PTDEBUG && _d("Nothing more to do, quitting");
return 0;
}
else {
# Wait for all other running instances to quit, assuming they have the
# same --interval as this invocation. Then remove the file and
# continue.
PTDEBUG && _d("Waiting for other instances to quit");
sleep $interval ;
PTDEBUG && _d("Unlinking", $sentinel);
unlink $sentinel
or die "Cannot unlink $sentinel: $OS_ERROR";
}
}
# ########################################################################
# Connect to MySQL.
# ########################################################################
if ( $o->get('ask-pass') ) {
$o->set('password', OptionParser::prompt_noecho("Enter password: "));
}
my $dsn_defaults = $dp->parse_options($o);
my $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults)
: $dsn_defaults;
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), {AutoCommit=>1});
$dbh->{InactiveDestroy} = 1; # Don't disconnect on fork
$dbh->{FetchHashKeyName} = 'NAME_lc';
$dbh->do("USE `$db`");
# ########################################################################
# If --check-read-only option was given and we are in --update mode
# we wait until server is writable , or run-time is over, or sentinel file
# We also do this check after daemon is up and running, but it is necessary
# to check this before attempting to create the table and inserting rows
# https://bugs.launchpad.net/percona-toolkit/+bug/1328686
# #######################################################################
if ( $o->get('check-read-only') && $o->get('update') ) {
PTDEBUG && _d('Checking if server is read_only');
if ( server_is_readonly($dbh) && PTDEBUG ) {
_d('Server is read-only, waiting')
}
my $start_time = time;
my $run_time = $o->get('run-time');
my $interval = $o->get('interval') || 5;
while (server_is_readonly($dbh)) {
sleep($interval);
if (
($run_time && $run_time < time - $start_time)
|| -f $sentinel
) {
return 0;
}
}
}
# ########################################################################
# Create the heartbeat table if --create-table was given.
# ########################################################################
my $utc = $o->get('utc');
my $now_func = $utc ? 'UTC_TIMESTAMP()' : 'NOW()';
my $db_tbl = $q->quote($db, $tbl);
my $server_id = $dbh->selectrow_array('SELECT @@server_id');
if ( $o->get('create-table') ) {
my $sql = $o->read_para_after(__FILE__, qr/MAGIC_create_heartbeat/);
$sql =~ s/heartbeat/IF NOT EXISTS $db_tbl/;
PTDEBUG && _d($sql);
$dbh->do($sql);
$sql = ($o->get('replace') ? "REPLACE" : "INSERT")
. qq/ INTO $db_tbl (ts, server_id) VALUES ($now_func, $server_id)/;
PTDEBUG && _d($sql);
# This may fail if the table already existed and already had this row.
# We eval to ignore this possibility.
# NOTE: This can break replication though! See:
# https://bugs.launchpad.net/percona-toolkit/+bug/1004567
# So --replace should be used in most cases.
eval { $dbh->do($sql); };
}
# ########################################################################
# Get and check heartbeat table structure.
# ########################################################################
my $tbl_def = $dbh->selectrow_arrayref("SHOW CREATE TABLE $db_tbl");
my $tbl_struct = $tp->parse($tbl_def->[1]);
die "Heartbeat table $db_tbl does not have a ts column"
unless $tbl_struct->{is_col}->{ts};
my $hires_ts = $tbl_struct->{type_for}->{ts} =~ m/char/i ? 1 : 0;
PTDEBUG && _d("Hi-res ts:", ($hires_ts ? 'yes' : 'no'));
my $id = $tbl_struct->{is_col}->{id}; # legacy table struct
die "Heartbeat table $db_tbl does not have a server_id or id column"
unless $tbl_struct->{is_col}->{server_id} || $id;
# If there's an id column, then we're running in legacy mode. If there's
# a server_id column, then we're running in the new mode which supports
# multiple --update instances.
if ( $tbl_struct->{is_col}->{id} && $tbl_struct->{is_col}->{server_id} ) {
die "Heartbeat table $db_tbl cannot have both an id column and "
. "a server_id column";
}
# pk_col and pk_val are used to identify the heartbeat row to update or
# or monitor.
my ($pk_col, $pk_val);
if ( $id ) {
# Legacy mode: update heartbeat row WHERE id=1 and monitor heartbeat
# row WHERE id=1.
$pk_col = 'id';
$pk_val = '1';
}
elsif ( $tbl_struct->{is_col}->{server_id} ) {
# Multi-update mode: update heartbeat row WHERE server_id=@@server_id
# and monitor heartbeat row WHERE server_id=master_server_id.
if ( $o->get('update') ) {
$pk_col = 'server_id';
$pk_val = $server_id;
}
else { # monitor or check
my $master_server_id = $o->get('master-server-id');
if ( !$master_server_id ) {
eval {
my $ms = new MasterSlave(
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
);
my $master_dsn = $ms->get_master_dsn($dbh, $dsn, $dp)
or die "This server is not a slave";
my $master_dbh = $dp->get_dbh($dp->get_cxn_params($master_dsn),
{ AutoCommit => 1 });
($master_server_id)
= $master_dbh->selectrow_array('SELECT @@server_id');
$master_dbh->disconnect;
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d("Error determining master id:", $EVAL_ERROR);
}
}
if ( !$master_server_id ) {
die "The --master-server-id option must be specified because "
. "the heartbeat table $db_tbl uses the server_id column "
. "for --update or --check but the server's master could "
. "not be automatically determined.\n"
. "Please read the DESCRIPTION section of the pt-heartbeat POD.\n";
}
$pk_col = 'server_id';
$pk_val = $master_server_id;
}
}
else {
die "Heartbeat table $db_tbl does not have a server_id or id column";
}
PTDEBUG && _d('Heartbeat row primary key:', $pk_col, '=', $pk_val);
# Check that heartbeat table has at least 1 row unless --replace because
# --replace will create the row if it doesn't exist.
if ( !$o->get('replace') ) {
my $sql = "SELECT 1 FROM $db_tbl WHERE $pk_col='$pk_val' LIMIT 1";
PTDEBUG && _d($sql);
my $row = $dbh->selectall_arrayref($sql);
if ( scalar @$row == 0 ) {
PTDEBUG && _d('No heartbeat row in table');
if ( $o->get('insert-heartbeat-row') ) {
my $sql = "INSERT INTO $db_tbl ($pk_col, ts) "
. "VALUES ('$pk_val', $now_func)";
PTDEBUG && _d($sql);
$dbh->do($sql);
}
else {
if ( $id ) {
die "The heartbeat table is empty.\n"
. "At least one row must be inserted into the heartbeat "
. "table.\nPlease read the DESCRIPTION section of the "
. "pt-heartbeat POD.\n";
}
else {
die "No row found in heartbeat table for server_id $pk_val.\n"
. "At least one row must be inserted into the heartbeat "
. "table for server_id $pk_val.\nPlease read the "
. "DESCRIPTION section of the pt-heartbeat POD.\n";
}
}
}
}
# ########################################################################
# Make sth for updating or checking the heartbeat table.
# ########################################################################
my ($heartbeat_sql, $heartbeat_sth);
my ($get_delay, $update_heartbeat);
if ( $o->get('update') ) {
my @master_status_cols = grep { $tbl_struct->{is_col}->{$_} }
qw(file position);
PTDEBUG && _d("Master status columns:", join(', ', @master_status_cols));
my @slave_status_cols = grep { $tbl_struct->{is_col}->{$_} }
qw(relay_master_log_file exec_master_log_pos);
PTDEBUG && _d("Slave status columns:", join(', ', @slave_status_cols));
# Just a shortcut so I don't have to check both arrays when creating
# SQL statement below.
my @extra_cols = (@master_status_cols, @slave_status_cols);
if ( $o->get('replace') ) {
$heartbeat_sql
= "REPLACE INTO $db_tbl (ts, $pk_col"
. (@extra_cols ? ", " . join(', ', @extra_cols) : '')
. ") VALUES (?, '$pk_val'"
. (@extra_cols ? ", " . join(', ', map { '?' } @extra_cols) : '')
. ")";
}
else {
$heartbeat_sql
= "UPDATE $db_tbl SET ts=?"
. (@extra_cols ? ", " . join(', ', map { "$_=?" } @extra_cols) : "")
. " WHERE $pk_col='$pk_val'";
}
PTDEBUG && _d("UPDATE SQL:", $heartbeat_sql);
$heartbeat_sth = $dbh->prepare($heartbeat_sql);
my $ro_check = !!$o->get('check-read-only');
$update_heartbeat = sub {
my ($sth) = @_;
my @vals;
return if $ro_check && server_is_readonly($dbh);
my $sql;
if ( @master_status_cols ) {
$sql = "SHOW MASTER STATUS";
PTDEBUG && _d($dbh, $sql);
my $row = $dbh->selectrow_hashref($sql);
if ( !$row ) {
PTDEBUG && _d("No row from", $sql);
push @vals, map { undef } @master_status_cols;
}
else {
push @vals, map { $row->{$_} } @master_status_cols;
}
}
if ( @slave_status_cols ) {
$sql = "SHOW SLAVE STATUS";
PTDEBUG && _d($dbh, $sql);
my $row = $dbh->selectrow_hashref($sql);
if ( !$row ) {
PTDEBUG && _d("No row from", $sql);
push @vals, map { undef } @slave_status_cols;
}
else {
push @vals, map { $row->{$_} } @slave_status_cols;
}
}
my $retry = Retry->new();
$retry->retry(
tries => 3,
wait => sub { sleep 0.25; return; },
try => sub {
$sth->execute(ts(time, $utc), @vals);
PTDEBUG && _d($sth->{Statement});
$sth->finish();
},
fail => sub {
my (%args) = @_;
my $error = $args{error};
if ( $error =~ m/Deadlock found/ ) {
return 1; # try again
}
else {
return 0;
}
},
final_fail => sub {
my (%args) = @_;
die $args{error};
}
);
return;
};
}
else { # --monitor or --check
my $dbi_driver = lc $o->get('dbi-driver');
# UNIX_TIMESTAMP(UTC_TIMESTAMP()) instead of UNIX_TIMESTAMP() alone,
# so we make sure that we aren't being fooled by a timezone.
# UNIX_TIMESTAMP(ts) replaces unix_timestamp($ts) -- MySQL is the
# authority here, so let it calculate everything.
$heartbeat_sql
= "SELECT " . ($utc ? 'UNIX_TIMESTAMP(ts)' : 'ts')
. ($dbi_driver eq 'mysql' ? '/*!50038, @@hostname AS host*/' : '')
. ($id ? "" : ", server_id")
. " FROM $db_tbl "
. "WHERE $pk_col='$pk_val' "
. "LIMIT 1";
PTDEBUG && _d("SELECT SQL:", $heartbeat_sql);
$heartbeat_sth = $dbh->prepare($heartbeat_sql);
$get_delay = sub {
my ($sth) = @_;
$sth->execute();
PTDEBUG && _d($sth->{Statement});
my ($ts, $hostname, $server_id) = $sth->fetchrow_array();
my $now = time;
PTDEBUG && _d("Heartbeat from server", $server_id, "\n",
" now:", ts($now, $utc), "\n",
" ts:", $ts, "\n",
"skew:", $skew);
my $delay = $now - unix_timestamp($ts, $utc) - $skew;
PTDEBUG && _d('Delay', sprintf('%.6f', $delay), 'on', $hostname);
# Because we adjust for skew, if the ts are less than skew seconds
# apart (i.e. replication is very fast) then delay will be negative.
# So it's effectively 0 seconds of lag.
$delay = 0.00 if $delay < 0;
$sth->finish();
return ($delay, $hostname, $pk_val);
};
# https://bugs.launchpad.net/percona-toolkit/+bug/1163372
# "pt-heartbeat --utc --check always returns 0"
if ( $utc ) {
my $sql = "SET time_zone='+0:00'";
PTDEBUG && _d($sql);
$dbh->do($sql);
}
}
# Do a little check just to make sure the table is there, so there's one last
# chance to catch errors before daemonizing.
if ( $o->get('update') ) {
$update_heartbeat->($heartbeat_sth);
}
else {
$get_delay->($heartbeat_sth);
}
$heartbeat_sth->finish();
# ########################################################################
# Daemonize only after (potentially) asking for passwords for --ask-pass.
# ########################################################################
my $daemon;
if ( $o->get('daemonize') ) {
$daemon = new Daemon(o=>$o);
$daemon->daemonize();
PTDEBUG && _d('I am a daemon now');
}
elsif ( $o->get('pid') ) {
# We're not daemoninzing, it just handles PID stuff.
$daemon = new Daemon(o=>$o);
$daemon->make_PID_file();
}
# ########################################################################
# --check and exit if --check was given.
# ########################################################################
if ( $o->get('check') ) {
PTDEBUG && _d('--check and exit');
check_delay(
dsn => $dsn,
dbh => $dbh,
sth => $heartbeat_sth,
sql => $heartbeat_sql,
get_delay => $get_delay,
interval => $interval,
skew => $skew,
hires_ts => $hires_ts,
OptionParser => $o,
DSNParser => $dp,
);
disconnect($dbh, $heartbeat_sth);
return 0;
}
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [ { dbh => $dbh, dsn => $dsn } ],
);
}
# ########################################################################
# Setup moving averages for --frames.
# ########################################################################
my @samples;
my $limit = max(@$frames);
# 2.00s [ 0.05s, 0.01s, 0.00s ]
my $format = ($hires_ts ? '%.2f' : '%4d') . "s "
. "[ " . join(", ", map { "%5.2fs" } @$frames) . " ]"
. ($o->get('print-master-server-id') ? " %d" : '')
. "\n";
# ########################################################################
# Monitor or update the heartbeat table.
# ########################################################################
my $end = $o->get('run-time') ? int(time + $o->get('run-time')) : 0;
PTDEBUG && _d($end ? ('Will exit at', ts($end)) : 'Running forever');
my $get_next_interval = make_interval_iter($interval, $skew);
while ( # Stop if...
(!$end || int(time) < $end) # runtime exceeded, or
&& !-f $sentinel # sentinel file created
) {
eval {
my $next_interval = $get_next_interval->();
# save current time in variable to avoid race condition
# https://bugs.launchpad.net/percona-toolkit/+bug/1406390
my $time = time;
if ( $time >= $next_interval ) {
do { $next_interval = $get_next_interval->() }
until $next_interval > $time;
PTDEBUG && _d("Missed last interval; next interval:",
ts($next_interval));
}
sleep $next_interval - $time;
PTDEBUG && _d('Woke up at', ts(time));
# Connect or reconnect if necessary.
if ( !$dbh->ping() ) {
$dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1 });
$dbh->{InactiveDestroy} = 1; # Don't disconnect on fork
$dbh->{FetchHashKeyName} = 'NAME_lc';
$dbh->do("USE `$db`");
$heartbeat_sth = undef;
}
if ( $o->get('monitor') ) {
$heartbeat_sth ||= $dbh->prepare($heartbeat_sql);
my ($delay) = $get_delay->($heartbeat_sth);
unshift @samples, $delay;
pop @samples if @samples > $limit;
# Calculate and print results
my @vals = map {
my $bound = min($_, scalar(@samples));
sum(@samples[0 .. $bound-1]) / $_;
} @$frames;
my $output = sprintf $format, $delay, @vals, $pk_val;
if ( my $file = $o->get('file') ) {
open my $file, '>', $file
or die "Can't open $file: $OS_ERROR";
print $file $output
or die "Can't print to $file: $OS_ERROR";
close $file
or die "Can't close $file: $OS_ERROR";
}
else {
print $output;
}
}
else { # --update mode
$heartbeat_sth ||= $dbh->prepare($heartbeat_sql);
$update_heartbeat->($heartbeat_sth);
}
};
if ( $EVAL_ERROR ) {
my ( $err ) = $EVAL_ERROR =~ m/^(?:DBI|DBD).*failed: (.*?)\s*at \S+ line .*/;
if ( $err ) {
warn "$err\n";
}
else {
die $EVAL_ERROR;
}
}
}
disconnect($dbh, $heartbeat_sth);
return 0;
}
# ############################################################################
# Subroutines.
# ############################################################################
sub server_is_readonly {
my ($dbh) = @_;
my ( $is_read_only ) = $dbh->selectrow_array(q{SELECT @@global.read_only});
if ( $is_read_only ) {
my ( $privs ) = eval { $dbh->selectrow_array(q{SHOW GRANTS}) };
if ( $privs && $privs =~ /\b(?:ALL|SUPER)\b/ ) {
$is_read_only = undef;
}
}
return $is_read_only;
}
# Check the delay on a single server. Optionally recurse to all its slaves.
sub check_delay {
my ( %args ) = @_;
my @required_args = qw(dsn dbh sth sql get_delay interval skew OptionParser DSNParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dsn, $dbh, $sth, $sql, $get_delay, $interval, $skew, $o, $dp)
= @args{@required_args};
PTDEBUG && _d('Checking slave delay');
# Collect a list of connections to the slaves.
if ( $o->get('recurse') ) {
PTDEBUG && _d('Recursing to slaves');
my $ms = new MasterSlave(
OptionParser => $o,
DSNParser => $dp,
Quoter => "Quoter",
);
$ms->recurse_to_slaves(
{ dbh => $dbh,
dsn => $dsn,
callback => sub {
my ( $dsn, $dbh, $level ) = @_;
push @dbhs, $dbh;
PTDEBUG && _d("Found slave", $dp->as_string($dsn));
push @sths, [ $dsn, $dbh->prepare($sql) ];
},
},
);
}
else {
push @sths, [ $dsn, $sth ];
}
my $format_delay = ($args{hires_ts} ? '%.2f' : '%d')
. ($o->get('print-master-server-id') ? " %d" : "")
. "\n";
my $format_host = "%-20s $format_delay";
# Before hi-res ts, we could check all slaves at one interval, assuming
# the checks were fast, i.e. able to be done within one interval. But
# now we have intervals up to 0.01 fast and that's too short to check all
# slaves. So for each slave we sleep until the next interval.
my $get_next_interval = make_interval_iter($interval, $skew);
SLAVE:
foreach my $thing ( @sths ) {
my ( $dsn, $sth ) = @$thing;
PTDEBUG && _d('Checking slave', $dp->as_string($dsn));
my $next_interval = $get_next_interval->();
# save current time in variable to avoid race condition
# https://bugs.launchpad.net/percona-toolkit/+bug/1406390
my $time = time;
if ( $time >= $next_interval ) {
do { $next_interval = $get_next_interval->() }
until $next_interval > $time;
PTDEBUG && _d("Missed last interval; next interval:",
ts($next_interval));
}
sleep $next_interval - $time;
PTDEBUG && _d('Woke up at', ts(time));
my ($delay, $hostname, $master_server_id) = $get_delay->($sth);
if ( $o->get('recurse') ) {
# Must print not only the delay, but the server's hostname if
# available. Prefer the hostname from the DSN, then the hostname
# from @@hostname, then fall back to Socket or default File.
my $host = $dsn->{h} || $hostname || $dsn->{S} || $dsn->{F} || '';
if ( $dsn->{P} && $dsn->{P} ne '3306' ) {
$host .= ":$dsn->{P}";
}
printf($format_host, $host, $delay, $master_server_id);
}
else {
# Just print the delay.
printf($format_delay, $delay, $master_server_id);
}
}
return;
}
# The interval iterator works by first returning the next whole second.
# So if the current time (since epoch) is 5.123, then the next whole second
# is 6.0, plus an optional skew. The next interval is 6.0 * the interval.
# If the interval is 0.5s, then the next interval is 6.5, plus an optional
# skew. Therefore, we always start on a whole second and return when the
# next interval is or should be. The caller can then sleep(time-next_interval)
# to wake up at that interval. If the caller misses the next interval,
# they just call the iterator until the next interval is later then the
# current time.
sub make_interval_iter {
my ( $interval, $skew ) = @_;
die "I need an interval argument" unless defined $interval;
my ($s) = gettimeofday();
my $start_s = $s + 1;
my $i = 0;
my $get_next_interval = sub {
return $start_s + ($interval * $i++) + $skew;
};
return $get_next_interval;
}
sub disconnect {
my ( $dbh, $sth ) = @_;
PTDEBUG && _d('Disconnecting');
$sth->finish() if $sth;
foreach my $handle ( @sths ) {
my $sth = $handle->[1];
$sth->finish() if $sth;
}
foreach my $handle ( $dbh, @dbhs ) {
$handle->disconnect() if $handle;
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation.
# ############################################################################
=pod
=head1 NAME
pt-heartbeat - Monitor MySQL replication delay.
=head1 SYNOPSIS
Usage: pt-heartbeat [OPTIONS] [DSN] --update|--monitor|--check|--stop
pt-heartbeat measures replication lag on a MySQL or PostgreSQL server. You can
use it to update a master or monitor a replica. If possible, MySQL connection
options are read from your .my.cnf file.
Start daemonized process to update test.heartbeat table on master:
pt-heartbeat -D test --update -h master-server --daemonize
Monitor replication lag on slave:
pt-heartbeat -D test --monitor -h slave-server
pt-heartbeat -D test --monitor -h slave-server --dbi-driver Pg
Check slave lag once and exit (using optional DSN to specify slave host):
pt-heartbeat -D test --check h=slave-server
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-heartbeat is a two-part MySQL and PostgreSQL replication delay monitoring
system that measures delay by looking at actual replicated data. This
avoids reliance on the replication mechanism itself, which is unreliable. (For
example, C on MySQL).
The first part is an L<"--update"> instance of pt-heartbeat that connects to
a master and updates a timestamp ("heartbeat record") every L<"--interval">
seconds. Since the heartbeat table may contain records from multiple
masters (see L<"MULTI-SLAVE HIERARCHY">), the server's ID (@@server_id) is
used to identify records.
The second part is a L<"--monitor"> or L<"--check"> instance of pt-heartbeat
that connects to a slave, examines the replicated heartbeat record from its
immediate master or the specified L<"--master-server-id">, and computes the
difference from the current system time. If replication between the slave and
the master is delayed or broken, the computed difference will be greater than
zero and potentially increase if L<"--monitor"> is specified.
You must either manually create the heartbeat table on the master or use
L<"--create-table">. See L<"--create-table"> for the proper heartbeat
table structure. The C storage engine is suggested, but not
required of course, for MySQL.
The heartbeat table must contain a heartbeat row. By default, a heartbeat
row is inserted if it doesn't exist. This feature can be disabled with the
L<"--[no]insert-heartbeat-row"> option in case the database user does not
have INSERT privileges.
pt-heartbeat depends only on the heartbeat record being replicated to the slave,
so it works regardless of the replication mechanism (built-in replication, a
system such as Continuent Tungsten, etc). It works at any depth in the
replication hierarchy; for example, it will reliably report how far a slave lags
its master's master's master. And if replication is stopped, it will continue
to work and report (accurately!) that the slave is falling further and further
behind the master.
pt-heartbeat has a maximum resolution of 0.01 second. The clocks on the
master and slave servers must be closely synchronized via NTP. By default,
L<"--update"> checks happen on the edge of the second (e.g. 00:01) and
L<"--monitor"> checks happen halfway between seconds (e.g. 00:01.5).
As long as the servers' clocks are closely synchronized and replication
events are propagating in less than half a second, pt-heartbeat will report
zero seconds of delay.
pt-heartbeat will try to reconnect if the connection has an error, but will
not retry if it can't get a connection when it first starts.
The L<"--dbi-driver"> option lets you use pt-heartbeat to monitor PostgreSQL
as well. It is reported to work well with Slony-1 replication.
=head1 MULTI-SLAVE HIERARCHY
If the replication hierarchy has multiple slaves which are masters of
other slaves, like "master -> slave1 -> slave2", L<"--update"> instances
can be ran on the slaves as well as the master. The default heartbeat
table (see L<"--create-table">) is keyed on the C column, so
each server will update the row where C.
For L<"--monitor"> and L<"--check">, if L<"--master-server-id"> is not
specified, the tool tries to discover and use the slave's immediate master.
If this fails, or if you want monitor lag from another master, then you can
specify the L<"--master-server-id"> to use.
For example, if the replication hierarchy is "master -> slave1 -> slave2"
with corresponding server IDs 1, 2 and 3, you can:
pt-heartbeat --daemonize -D test --update -h master
pt-heartbeat --daemonize -D test --update -h slave1
Then check (or monitor) the replication delay from master to slave2:
pt-heartbeat -D test --master-server-id 1 --check slave2
Or check the replication delay from slave1 to slave2:
pt-heartbeat -D test --master-server-id 2 --check slave2
Stopping the L<"--update"> instance one slave1 will not affect the instance
on master.
=head1 MASTER AND SLAVE STATUS
The default heartbeat table (see L<"--create-table">) has columns for saving
information from C and C. These
columns are optional. If any are present, their corresponding information
will be saved.
=head1 Percona XtraDB Cluster
Although pt-heartbeat should work with all supported versions of Percona XtraDB
Cluster (PXC), we recommend using 5.5.28-23.7 and newer.
If you are setting up heartbeat instances between cluster nodes, keep in mind
that, since the speed of the cluster is determined by its slowest node,
pt-heartbeat will not report how fast the cluster itself is, but only how
fast events are replicating from one node to another.
You must specify L<"--master-server-id"> for L<"--monitor"> and L<"--check">
instances.
=head1 OPTIONS
Specify at least one of L<"--stop">, L<"--update">, L<"--monitor">, or L<"--check">.
L<"--update">, L<"--monitor">, and L<"--check"> are mutually exclusive.
L<"--daemonize"> and L<"--check"> are mutually exclusive.
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --charset
short form: -A; type: string
Default character set. If the value is utf8, sets Perl's binmode on STDOUT to
utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET NAMES UTF8
after connecting to MySQL. Any other value sets binmode on STDOUT without the
utf8 layer, and runs SET NAMES after connecting to MySQL.
=item --check
Check slave delay once and exit. If you also specify L<"--recurse">, the
tool will try to discover slave's of the given slave and check and print
their lag, too. The hostname or IP and port for each slave is printed
before its delay. L<"--recurse"> only works with MySQL.
=item --check-read-only
Check if the server has read_only enabled; If it does, the tool skips doing
any inserts.
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line.
=item --create-table
Create the heartbeat L<"--table"> if it does not exist.
This option causes the table specified by L<"--database"> and L<"--table"> to
be created with the following MAGIC_create_heartbeat table definition:
CREATE TABLE heartbeat (
ts varchar(26) NOT NULL,
server_id int unsigned NOT NULL PRIMARY KEY,
file varchar(255) DEFAULT NULL, -- SHOW MASTER STATUS
position bigint unsigned DEFAULT NULL, -- SHOW MASTER STATUS
relay_master_log_file varchar(255) DEFAULT NULL, -- SHOW SLAVE STATUS
exec_master_log_pos bigint unsigned DEFAULT NULL -- SHOW SLAVE STATUS
);
The heartbeat table requires at least one row. If you manually create the
heartbeat table, then you must insert a row by doing:
INSERT INTO heartbeat (ts, server_id) VALUES (NOW(), N);
or if using L<"--utc">:
INSERT INTO heartbeat (ts, server_id) VALUES (UTC_TIMESTAMP(), N);
where C is the server's ID; do not use @@server_id because it will replicate
and slaves will insert their own server ID instead of the master's server ID.
This is done automatically by L<"--create-table">.
A legacy version of the heartbeat table is still supported:
CREATE TABLE heartbeat (
id int NOT NULL PRIMARY KEY,
ts datetime NOT NULL
);
Legacy tables do not support L<"--update"> instances on each slave
of a multi-slave hierarchy like "master -> slave1 -> slave2".
To manually insert the one required row into a legacy table:
INSERT INTO heartbeat (id, ts) VALUES (1, NOW());
or if using L<"--utc">:
INSERT INTO heartbeat (id, ts) VALUES (1, UTC_TIMESTAMP());
The tool automatically detects if the heartbeat table is legacy.
See also L<"MULTI-SLAVE HIERARCHY">.
=item --daemonize
Fork to the background and detach from the shell. POSIX operating systems only.
=item --database
short form: -D; type: string
The database to use for the connection.
=item --dbi-driver
default: mysql; type: string
Specify a driver for the connection; C and C are supported.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute
pathname.
=item --file
type: string
Print latest L<"--monitor"> output to this file.
When L<"--monitor"> is given, prints output to the specified file instead of to
STDOUT. The file is opened, truncated, and closed every interval, so it will
only contain the most recent statistics. Useful when L<"--daemonize"> is given.
=item --frames
type: string; default: 1m,5m,15m
Timeframes for averages.
Specifies the timeframes over which to calculate moving averages when
L<"--monitor"> is given. Specify as a comma-separated list of numbers with
suffixes. The suffix can be s for seconds, m for minutes, h for hours, or d for
days. The size of the largest frame determines the maximum memory usage, as up
to the specified number of per-second samples are kept in memory to calculate
the averages. You can specify as many timeframes as you like.
=item --help
Show help and exit.
=item --host
short form: -h; type: string
Connect to host.
=item --[no]insert-heartbeat-row
default: yes
Insert a heartbeat row in the L<"--table"> if one doesn't exist.
The heartbeat L<"--table"> requires a heartbeat row, else there's nothing
to L<"--update">, L<"--monitor">, or L<"--check">! By default, the tool will
insert a heartbeat row if one is not already present. You can disable this
feature by specifying C<--no-insert-heartbeat-row> in case the database user
does not have INSERT privileges.
=item --interval
type: float; default: 1.0
How often to update or check the heartbeat L<"--table">. Updates and checks
begin on the first whole second then repeat every L<"--interval"> seconds
for L<"--update"> and every L<"--interval"> plus L<"--skew"> seconds for
L<"--monitor">.
For example, if at 00:00.4 an L<"--update"> instance is started at 0.5 second
intervals, the first update happens at 00:01.0, the next at 00:01.5, etc.
If at 00:10.7 a L<"--monitor"> instance is started at 0.05 second intervals
with the default 0.5 second L<"--skew">, then the first check happens at
00:11.5 (00:11.0 + 0.5) which will be L<"--skew"> seconds after the last update
which, because the instances are checking at synchronized intervals, happened
at 00:11.0.
The tool waits for and begins on the first whole second just to make the
interval calculations simpler. Therefore, the tool could wait up to 1 second
before updating or checking.
The minimum (fastest) interval is 0.01, and the maximum precision is two
decimal places, so 0.015 will be rounded to 0.02.
If a legacy heartbeat table (see L<"--create-table">) is used, then the
maximum precision is 1s because the C column is type C.
=item --log
type: string
Print all output to this file when daemonized.
=item --master-server-id
type: string
Calculate delay from this master server ID for L<"--monitor"> or L<"--check">.
If not given, pt-heartbeat attempts to connect to the server's master and
determine its server id.
=item --monitor
Monitor slave delay continuously.
Specifies that pt-heartbeat should check the slave's delay every second and
report to STDOUT (or if L<"--file"> is given, to the file instead). The output
is the current delay followed by moving averages over the timeframe given in
L<"--frames">. For example,
5s [ 0.25s, 0.05s, 0.02s ]
=item --password
short form: -p; type: string
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item --pid
type: string
Create the given PID file. The tool won't start if the PID file already
exists and the PID it contains is different than the current PID. However,
if the PID file exists and the PID it contains is no longer running, the
tool will overwrite the PID file with the current PID. The PID file is
removed automatically when the tool exits.
=item --port
short form: -P; type: int
Port number to use for connection.
=item --print-master-server-id
Print the auto-detected or given L<"--master-server-id">. If L<"--check">
or L<"--monitor"> is specified, specifying this option will print the
auto-detected or given L<"--master-server-id"> at the end of each line.
=item --recurse
type: int
Check slaves recursively to this depth in L<"--check"> mode.
Try to discover slave servers recursively, to the specified depth. After
discovering servers, run the check on each one of them and print the hostname
(if possible), followed by the slave delay.
This currently works only with MySQL. See L<"--recursion-method">.
=item --recursion-method
type: array; default: processlist,hosts
Preferred recursion method used to find slaves.
Possible methods are:
METHOD USES
=========== ==================
processlist SHOW PROCESSLIST
hosts SHOW SLAVE HOSTS
none Do not find slaves
The processlist method is preferred because SHOW SLAVE HOSTS is not reliable.
However, the hosts method is required if the server uses a non-standard
port (not 3306). Usually pt-heartbeat does the right thing and finds
the slaves, but you may give a preferred method and it will be used first.
If it doesn't find any slaves, the other methods will be tried.
=item --replace
Use C instead of C for --update.
When running in L<"--update"> mode, use C instead of C to set
the heartbeat table's timestamp. The C statement is a MySQL extension
to SQL. This option is useful when you don't know whether the table contains
any rows or not. It must be used in conjunction with --update.
=item --run-time
type: time
Time to run before exiting.
=item --sentinel
type: string; default: /tmp/pt-heartbeat-sentinel
Exit if this file exists.
=item --set-vars
type: Array
Set the MySQL variables in this comma-separated list of C pairs.
By default, the tool sets:
=for comment ignore-pt-internal-value
MAGIC_set_vars
wait_timeout=10000
Variables specified on the command line override these defaults. For
example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
The tool prints a warning and continues if a variable cannot be set.
=item --skew
type: float; default: 0.5
How long to delay checks.
The default is to delay checks one half second. Since the update happens as
soon as possible after the beginning of the second on the master, this allows
one half second of replication delay before reporting that the slave lags the
master by one second. If your clocks are not completely accurate or there is
some other reason you'd like to delay the slave more or less, you can tweak this
value. Try setting the C environment variable to see the effect this
has.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --stop
Stop running instances by creating the sentinel file.
This should have the effect of stopping all running
instances which are watching the same sentinel file. If none of
L<"--update">, L<"--monitor"> or L<"--check"> is specified, C
will exit after creating the file. If one of these is specified,
C will wait the interval given by L<"--interval">, then remove
the file and continue working.
You might find this handy to stop cron jobs gracefully if necessary, or to
replace one running instance with another. For example, if you want to stop
and restart C every hour (just to make sure that it is restarted
every hour, in case of a server crash or some other problem), you could use a
C line like this:
0 * * * * pt-heartbeat --update -D test --stop \
--sentinel /tmp/pt-heartbeat-hourly
The non-default L<"--sentinel"> will make sure the hourly C job stops
only instances previously started with the same options (that is, from the
same C job).
See also L<"--sentinel">.
=item --table
type: string; default: heartbeat
The table to use for the heartbeat.
Don't specify database.table; use L<"--database"> to specify the database.
See L<"--create-table">.
=item --update
Update a master's heartbeat.
=item --user
short form: -u; type: string
User for login if not current user.
=item --utc
Ignore system time zones and use only UTC. By default pt-heartbeat does
not check or adjust for different system or MySQL time zones which can
cause the tool to compute the lag incorrectly. Specifying this option is
a good idea because it ensures that the tool works correctly regardless of
time zones.
If used, this option must be used for all pt-heartbeat instances:
L<"--update">, L<"--monitor">, L<"--check">, etc. You should probably
set the option in a L<"--config"> file. Mixing this option with pt-heartbeat
instances not using this option will cause false-positive lag readings
due to different time zones (unless all your systems are set to use UTC,
in which case this option isn't required).
=item --version
Show version and exit.
=item --[no]version-check
default: yes
Check for the latest version of Percona Toolkit, MySQL, and other programs.
This is a standard "check for updates automatically" feature, with two
additional features. First, the tool checks the version of other programs
on the local system in addition to its own version. For example, it checks
the version of every MySQL server it connects to, Perl, and the Perl module
DBD::mysql. Second, it checks for and warns about versions with known
problems. For example, MySQL 5.5.25 had a critical bug and was re-released
as 5.5.25a.
Any updates or known problems are printed to STDOUT before the tool's normal
output. This feature should never interfere with the normal operation of the
tool.
For more information, visit L.
=back
=head1 DSN OPTIONS
These DSN options are used to create a DSN. Each option is given like
C. The options are case-sensitive, so P and p are not the
same option. There cannot be whitespace before or after the C<=> and
if the value contains whitespace it must be quoted. DSN options are
comma-separated. See the L manpage for full details.
=over
=item * A
dsn: charset; copy: yes
Default character set.
=item * D
dsn: database; copy: yes
Default database.
=item * F
dsn: mysql_read_default_file; copy: yes
Only read default options from the given file
=item * h
dsn: host; copy: yes
Connect to host.
=item * p
dsn: password; copy: yes
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item * P
dsn: port; copy: yes
Port number to use for connection.
=item * S
dsn: mysql_socket; copy: yes
Socket file to use for connection.
=item * u
dsn: user; copy: yes
User for login if not current user.
=back
=head1 ENVIRONMENT
The environment variable C enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-heartbeat ... > FILE 2>&1
Be careful: debugging output is voluminous and can generate several megabytes
of output.
=head1 SYSTEM REQUIREMENTS
You need Perl, DBI, DBD::mysql, and some core packages that ought to be
installed in any reasonably new version of Perl.
=head1 BUGS
For a list of known bugs, see L.
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L with the name of any tool.
=head1 AUTHORS
Proven Scaling LLC, SixApart Ltd, Baron Schwartz, and Daniel Nichter
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L
. qq
. (defined $val ? Lmo::Dumper($val) : 'undef') )
}
sub _nested_constraints {
my ($attribute, $aggregate_type, $type) = @_;
my $inner_types;
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$inner_types = _nested_constraints($1, $2);
}
else {
$inner_types = $TYPES{$type};
}
if ( $aggregate_type eq 'ArrayRef' ) {
return sub {
my ($val) = @_;
return unless ref($val) eq ref([]);
if ($inner_types) {
for my $value ( @{$val} ) {
return unless $inner_types->($value)
}
}
else {
for my $value ( @{$val} ) {
return unless $value && ($value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type)));
}
}
return 1;
};
}
elsif ( $aggregate_type eq 'Maybe' ) {
return sub {
my ($value) = @_;
return 1 if ! defined($value);
if ($inner_types) {
return unless $inner_types->($value)
}
else {
return unless $value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type));
}
return 1;
}
}
else {
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
}
}
1;
}
# ###########################################################################
# End Lmo::Types package
# ###########################################################################
# ###########################################################################
# Lmo package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo.pm
# t/lib/Lmo.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
BEGIN {
$INC{"Lmo.pm"} = __FILE__;
package Lmo;
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
use Lmo::Meta;
use Lmo::Object;
use Lmo::Types;
use Lmo::Utils;
my %export_for;
sub import {
warnings->import(qw(FATAL all));
strict->import();
my $caller = scalar caller(); # Caller's package
my %exports = (
extends => \&extends,
has => \&has,
with => \&with,
override => \&override,
confess => \&Carp::confess,
);
$export_for{$caller} = \%exports;
for my $keyword ( keys %exports ) {
_install_coderef "${caller}::$keyword" => $exports{$keyword};
}
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
@_ = "Lmo::Object";
goto *{ _glob_for "${caller}::extends" }{CODE};
}
}
sub extends {
my $caller = scalar caller();
for my $class ( @_ ) {
_load_module($class);
}
_set_package_isa($caller, @_);
_set_inherited_metadata($caller);
}
sub _load_module {
my ($class) = @_;
(my $file = $class) =~ s{::|'}{/}g;
$file .= '.pm';
{ local $@; eval { require "$file" } } # or warn $@;
return;
}
sub with {
my $package = scalar caller();
require Role::Tiny;
for my $role ( @_ ) {
_load_module($role);
_role_attribute_metadata($package, $role);
}
Role::Tiny->apply_roles_to_package($package, @_);
}
sub _role_attribute_metadata {
my ($package, $role) = @_;
my $package_meta = Lmo::Meta->metadata_for($package);
my $role_meta = Lmo::Meta->metadata_for($role);
%$package_meta = (%$role_meta, %$package_meta);
}
sub has {
my $names = shift;
my $caller = scalar caller();
my $class_metadata = Lmo::Meta->metadata_for($caller);
for my $attribute ( ref $names ? @$names : $names ) {
my %args = @_;
my $method = ($args{is} || '') eq 'ro'
? sub {
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
if $#_;
return $_[0]{$attribute};
}
: sub {
return $#_
? $_[0]{$attribute} = $_[1]
: $_[0]{$attribute};
};
$class_metadata->{$attribute} = ();
if ( my $type_check = $args{isa} ) {
my $check_name = $type_check;
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
}
my $check_sub = sub {
my ($new_val) = @_;
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
};
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
my $orig_method = $method;
$method = sub {
$check_sub->($_[1]) if $#_;
goto &$orig_method;
};
}
if ( my $builder = $args{builder} ) {
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$builder
: goto &$original_method
};
}
if ( my $code = $args{default} ) {
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
unless ref($code) eq 'CODE';
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$code
: goto &$original_method
};
}
if ( my $role = $args{does} ) {
my $original_method = $method;
$method = sub {
if ( $#_ ) {
Carp::confess(qq)
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
}
goto &$original_method
};
}
if ( my $coercion = $args{coerce} ) {
$class_metadata->{$attribute}{coerce} = $coercion;
my $original_method = $method;
$method = sub {
if ( $#_ ) {
return $original_method->($_[0], $coercion->($_[1]))
}
goto &$original_method;
}
}
_install_coderef "${caller}::$attribute" => $method;
if ( $args{required} ) {
$class_metadata->{$attribute}{required} = 1;
}
if ($args{clearer}) {
_install_coderef "${caller}::$args{clearer}"
=> sub { delete shift->{$attribute} }
}
if ($args{predicate}) {
_install_coderef "${caller}::$args{predicate}"
=> sub { exists shift->{$attribute} }
}
if ($args{handles}) {
_has_handles($caller, $attribute, \%args);
}
if (exists $args{init_arg}) {
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
}
}
}
sub _has_handles {
my ($caller, $attribute, $args) = @_;
my $handles = $args->{handles};
my $ref = ref $handles;
my $kv;
if ( $ref eq ref [] ) {
$kv = { map { $_,$_ } @{$handles} };
}
elsif ( $ref eq ref {} ) {
$kv = $handles;
}
elsif ( $ref eq ref qr// ) {
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
unless $args->{isa};
my $target_class = $args->{isa};
$kv = {
map { $_, $_ }
grep { $_ =~ $handles }
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
grep { !$export_for{$target_class}->{$_} }
keys %{ _stash_for $target_class }
};
}
else {
Carp::confess("handles for $ref not yet implemented");
}
while ( my ($method, $target) = each %{$kv} ) {
my $name = _glob_for "${caller}::$method";
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
if defined &$name;
my ($target, @curried_args) = ref($target) ? @$target : $target;
*$name = sub {
my $self = shift;
my $delegate_to = $self->$attribute();
my $error = "Cannot delegate $method to $target because the value of $attribute";
Carp::confess("$error is not defined") unless $delegate_to;
Carp::confess("$error is not an object (got '$delegate_to')")
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
return $delegate_to->$target(@curried_args, @_);
}
}
}
sub _set_package_isa {
my ($package, @new_isa) = @_;
my $package_isa = \*{ _glob_for "${package}::ISA" };
@{*$package_isa} = @new_isa;
}
sub _set_inherited_metadata {
my $class = shift;
my $class_metadata = Lmo::Meta->metadata_for($class);
my $linearized_isa = mro::get_linear_isa($class);
my %new_metadata;
for my $isa_class (reverse @$linearized_isa) {
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
%new_metadata = (
%new_metadata,
%$isa_metadata,
);
}
%$class_metadata = %new_metadata;
}
sub unimport {
my $caller = scalar caller();
my $target = caller;
_unimport_coderefs($target, keys %{$export_for{$caller}});
}
sub Dumper {
require Data::Dumper;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Sortkeys = 0;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_)
}
BEGIN {
if ($] >= 5.010) {
{ local $@; require mro; }
}
else {
local $@;
eval {
require MRO::Compat;
} or do {
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
no strict 'refs';
my $classname = shift;
my @lin = ($classname);
my %stored;
foreach my $parent (@{"$classname\::ISA"}) {
my $plin = mro::get_linear_isa_dfs($parent);
foreach (@$plin) {
next if exists $stored{$_};
push(@lin, $_);
$stored{$_} = 1;
}
}
return \@lin;
};
}
}
}
sub override {
my ($methods, $code) = @_;
my $caller = scalar caller;
for my $method ( ref($methods) ? @$methods : $methods ) {
my $full_method = "${caller}::${method}";
*{_glob_for $full_method} = $code;
}
}
}
1;
}
# ###########################################################################
# End Lmo package
# ###########################################################################
# ###########################################################################
# OptionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/OptionParser.pm
# t/lib/OptionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OptionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
use Data::Dumper;
my $POD_link_re = '[LC]<"?([^">]+)"?>';
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
$program_name ||= $PROGRAM_NAME;
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my %attributes = (
'type' => 1,
'short form' => 1,
'group' => 1,
'default' => 1,
'cumulative' => 1,
'negatable' => 1,
'repeatable' => 1, # means it can be specified more than once
);
my $self = {
head1 => 'OPTIONS', # These args are used internally
skip_rules => 0, # to instantiate another Option-
item => '--(.*)', # Parser obj that parses the
attributes => \%attributes, # DSN OPTIONS section. Tools
parse_attributes => \&_parse_attribs, # don't tinker with these args.
%args,
strict => 1, # disabled by a special rule
program_name => $program_name,
opts => {},
got_opts => 0,
short_opts => {},
defaults => {},
groups => {},
allowed_groups => {},
errors => [],
rules => [], # desc of rules for --help
mutex => [], # rule: opts are mutually exclusive
atleast1 => [], # rule: at least one opt is required
disables => {}, # rule: opt disables other opts
defaults_to => {}, # rule: opt defaults to value of other opt
DSNParser => undef,
default_files => [
"/etc/percona-toolkit/percona-toolkit.conf",
"/etc/percona-toolkit/$program_name.conf",
"$home/.percona-toolkit.conf",
"$home/.$program_name.conf",
],
types => {
string => 's', # standard Getopt type
int => 'i', # standard Getopt type
float => 'f', # standard Getopt type
Hash => 'H', # hash, formed from a comma-separated list
hash => 'h', # hash as above, but only if a value is given
Array => 'A', # array, similar to Hash
array => 'a', # array, similar to hash
DSN => 'd', # DSN
size => 'z', # size with kMG suffix (powers of 2^10)
time => 'm', # time, with an optional suffix of s/h/m/d
},
};
return bless $self, $class;
}
sub get_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
my @specs = $self->_pod_to_specs($file);
$self->_parse_specs(@specs);
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
PTDEBUG && _d('Parsing DSN OPTIONS');
my $dsn_attribs = {
dsn => 1,
copy => 1,
};
my $parse_dsn_attribs = sub {
my ( $self, $option, $attribs ) = @_;
map {
my $val = $attribs->{$_};
if ( $val ) {
$val = $val eq 'yes' ? 1
: $val eq 'no' ? 0
: $val;
$attribs->{$_} = $val;
}
} keys %$attribs;
return {
key => $option,
%$attribs,
};
};
my $dsn_o = new OptionParser(
description => 'DSN OPTIONS',
head1 => 'DSN OPTIONS',
dsn => 0, # XXX don't infinitely recurse!
item => '\* (.)', # key opts are a single character
skip_rules => 1, # no rules before opts
attributes => $dsn_attribs,
parse_attributes => $parse_dsn_attribs,
);
my @dsn_opts = map {
my $opts = {
key => $_->{spec}->{key},
dsn => $_->{spec}->{dsn},
copy => $_->{spec}->{copy},
desc => $_->{desc},
};
$opts;
} $dsn_o->_pod_to_specs($file);
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
}
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
$self->{version} = $1;
PTDEBUG && _d($self->{version});
}
return;
}
sub DSNParser {
my ( $self ) = @_;
return $self->{DSNParser};
};
sub get_defaults_files {
my ( $self ) = @_;
return @{$self->{default_files}};
}
sub _pod_to_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my @specs = ();
my @rules = ();
my $para;
local $INPUT_RECORD_SEPARATOR = '';
while ( $para = <$fh> ) {
next unless $para =~ m/^=head1 $self->{head1}/;
last;
}
while ( $para = <$fh> ) {
last if $para =~ m/^=over/;
next if $self->{skip_rules};
chomp $para;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
PTDEBUG && _d('Option rule:', $para);
push @rules, $para;
}
die "POD has no $self->{head1} section" unless $para;
do {
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
chomp $para;
PTDEBUG && _d($para);
my %attribs;
$para = <$fh>; # read next paragraph, possibly attributes
if ( $para =~ m/: / ) { # attributes
$para =~ s/\s+\Z//g;
%attribs = map {
my ( $attrib, $val) = split(/: /, $_);
die "Unrecognized attribute for --$option: $attrib"
unless $self->{attributes}->{$attrib};
($attrib, $val);
} split(/; /, $para);
if ( $attribs{'short form'} ) {
$attribs{'short form'} =~ s/-//;
}
$para = <$fh>; # read next paragraph, probably short help desc
}
else {
PTDEBUG && _d('Option has no attributes');
}
$para =~ s/\s+\Z//g;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
PTDEBUG && _d('Short help:', $para);
die "No description after option spec $option" if $para =~ m/^=item/;
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
$option = $base_option;
$attribs{'negatable'} = 1;
}
push @specs, {
spec => $self->{parse_attributes}->($self, $option, \%attribs),
desc => $para
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
attributes => \%attribs
};
}
while ( $para = <$fh> ) {
last unless $para;
if ( $para =~ m/^=head1/ ) {
$para = undef; # Can't 'last' out of a do {} block.
last;
}
last if $para =~ m/^=item /;
}
} while ( $para );
die "No valid specs in $self->{head1}" unless @specs;
close $fh;
return @specs, @rules;
}
sub _parse_specs {
my ( $self, @specs ) = @_;
my %disables; # special rule that requires deferred checking
foreach my $opt ( @specs ) {
if ( ref $opt ) { # It's an option spec, not a rule.
PTDEBUG && _d('Parsing opt spec:',
map { ($_, '=>', $opt->{$_}) } keys %$opt);
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
if ( !$long ) {
die "Cannot parse long option from spec $opt->{spec}";
}
$opt->{long} = $long;
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
$self->{opts}->{$long} = $opt;
if ( length $long == 1 ) {
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
$self->{short_opts}->{$long} = $long;
}
if ( $short ) {
die "Duplicate short option -$short"
if exists $self->{short_opts}->{$short};
$self->{short_opts}->{$short} = $long;
$opt->{short} = $short;
}
else {
$opt->{short} = undef;
}
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
$opt->{is_repeatable} = $opt->{attributes}->{repeatable} ? 1 : 0;
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
$opt->{group} ||= 'default';
$self->{groups}->{ $opt->{group} }->{$long} = 1;
$opt->{value} = undef;
$opt->{got} = 0;
my ( $type ) = $opt->{spec} =~ m/=(.)/;
$opt->{type} = $type;
PTDEBUG && _d($long, 'type:', $type);
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
$self->{defaults}->{$long} = defined $def ? $def : 1;
PTDEBUG && _d($long, 'default:', $def);
}
if ( $long eq 'config' ) {
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
}
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
$disables{$long} = $dis;
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
PTDEBUG && _d('Parsing rule:', $opt);
push @{$self->{rules}}, $opt;
my @participants = $self->_get_participants($opt);
my $rule_ok = 0;
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
$rule_ok = 1;
push @{$self->{mutex}}, \@participants;
PTDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
PTDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
}
if ( $opt =~ m/restricted to option groups/ ) {
$rule_ok = 1;
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
my @groups = split(',', $groups);
%{$self->{allowed_groups}->{$participants[0]}} = map {
s/\s+//;
$_ => 1;
} @groups;
}
if( $opt =~ m/accepts additional command-line arguments/ ) {
$rule_ok = 1;
$self->{strict} = 0;
PTDEBUG && _d("Strict mode disabled by rule");
}
die "Unrecognized option rule: $opt" unless $rule_ok;
}
}
foreach my $long ( keys %disables ) {
my @participants = $self->_get_participants($disables{$long});
$self->{disables}->{$long} = \@participants;
PTDEBUG && _d('Option', $long, 'disables', @participants);
}
return;
}
sub _get_participants {
my ( $self, $str ) = @_;
my @participants;
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
die "Option --$long does not exist while processing rule $str"
unless exists $self->{opts}->{$long};
push @participants, $long;
}
PTDEBUG && _d('Participants for', $str, ':', @participants);
return @participants;
}
sub opts {
my ( $self ) = @_;
my %opts = %{$self->{opts}};
return %opts;
}
sub short_opts {
my ( $self ) = @_;
my %short_opts = %{$self->{short_opts}};
return %short_opts;
}
sub set_defaults {
my ( $self, %defaults ) = @_;
$self->{defaults} = {};
foreach my $long ( keys %defaults ) {
die "Cannot set default for nonexistent option $long"
unless exists $self->{opts}->{$long};
$self->{defaults}->{$long} = $defaults{$long};
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
}
return;
}
sub get_defaults {
my ( $self ) = @_;
return $self->{defaults};
}
sub get_groups {
my ( $self ) = @_;
return $self->{groups};
}
sub _set_option {
my ( $self, $opt, $val ) = @_;
my $long = exists $self->{opts}->{$opt} ? $opt
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
: die "Getopt::Long gave a nonexistent option: $opt";
$opt = $self->{opts}->{$long};
if ( $opt->{is_cumulative} ) {
$opt->{value}++;
}
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
my $next_opt = $1;
if ( exists $self->{opts}->{$next_opt}
|| exists $self->{short_opts}->{$next_opt} ) {
$self->save_error("--$long requires a string value");
return;
}
else {
if ($opt->{is_repeatable}) {
push @{$opt->{value}} , $val;
}
else {
$opt->{value} = $val;
}
}
}
else {
if ($opt->{is_repeatable}) {
push @{$opt->{value}} , $val;
}
else {
$opt->{value} = $val;
}
}
$opt->{got} = 1;
PTDEBUG && _d('Got option', $long, '=', $val);
}
sub get_opts {
my ( $self ) = @_;
foreach my $long ( keys %{$self->{opts}} ) {
$self->{opts}->{$long}->{got} = 0;
$self->{opts}->{$long}->{value}
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
: $self->{opts}->{$long}->{is_cumulative} ? 0
: undef;
}
$self->{got_opts} = 0;
$self->{errors} = [];
if ( @ARGV && $ARGV[0] eq "--config" ) {
shift @ARGV;
$self->_set_option('config', shift @ARGV);
}
if ( $self->has('config') ) {
my @extra_args;
foreach my $filename ( split(',', $self->get('config')) ) {
eval {
push @extra_args, $self->_read_config_file($filename);
};
if ( $EVAL_ERROR ) {
if ( $self->got('config') ) {
die $EVAL_ERROR;
}
elsif ( PTDEBUG ) {
_d($EVAL_ERROR);
}
}
}
unshift @ARGV, @extra_args;
}
Getopt::Long::Configure('no_ignore_case', 'bundling');
GetOptions(
map { $_->{spec} => sub { $self->_set_option(@_); } }
grep { $_->{long} ne 'config' } # --config is handled specially above.
values %{$self->{opts}}
) or $self->save_error('Error parsing options');
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
if ( $self->{version} ) {
print $self->{version}, "\n";
}
else {
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
}
exit 1;
}
if ( @ARGV && $self->{strict} ) {
$self->save_error("Unrecognized command-line options @ARGV");
}
foreach my $mutex ( @{$self->{mutex}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
if ( @set > 1 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
. ' are mutually exclusive.';
$self->save_error($err);
}
}
foreach my $required ( @{$self->{atleast1}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
if ( @set == 0 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$required}[ 0 .. scalar(@$required) - 2] )
.' or --'.$self->{opts}->{$required->[-1]}->{long};
$self->save_error("Specify at least one of $err");
}
}
$self->_check_opts( keys %{$self->{opts}} );
$self->{got_opts} = 1;
return;
}
sub _check_opts {
my ( $self, @long ) = @_;
my $long_last = scalar @long;
while ( @long ) {
foreach my $i ( 0..$#long ) {
my $long = $long[$i];
next unless $long;
my $opt = $self->{opts}->{$long};
if ( $opt->{got} ) {
if ( exists $self->{disables}->{$long} ) {
my @disable_opts = @{$self->{disables}->{$long}};
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
PTDEBUG && _d('Unset options', @disable_opts,
'because', $long,'disables them');
}
if ( exists $self->{allowed_groups}->{$long} ) {
my @restricted_groups = grep {
!exists $self->{allowed_groups}->{$long}->{$_}
} keys %{$self->{groups}};
my @restricted_opts;
foreach my $restricted_group ( @restricted_groups ) {
RESTRICTED_OPT:
foreach my $restricted_opt (
keys %{$self->{groups}->{$restricted_group}} )
{
next RESTRICTED_OPT if $restricted_opt eq $long;
push @restricted_opts, $restricted_opt
if $self->{opts}->{$restricted_opt}->{got};
}
}
if ( @restricted_opts ) {
my $err;
if ( @restricted_opts == 1 ) {
$err = "--$restricted_opts[0]";
}
else {
$err = join(', ',
map { "--$self->{opts}->{$_}->{long}" }
grep { $_ }
@restricted_opts[0..scalar(@restricted_opts) - 2]
)
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
}
$self->save_error("--$long is not allowed with $err");
}
}
}
elsif ( $opt->{is_required} ) {
$self->save_error("Required option --$long must be specified");
}
$self->_validate_type($opt);
if ( $opt->{parsed} ) {
delete $long[$i];
}
else {
PTDEBUG && _d('Temporarily failed to parse', $long);
}
}
die "Failed to parse options, possibly due to circular dependencies"
if @long == $long_last;
$long_last = @long;
}
return;
}
sub _validate_type {
my ( $self, $opt ) = @_;
return unless $opt;
if ( !$opt->{type} ) {
$opt->{parsed} = 1;
return;
}
my $val = $opt->{value};
if ( $val && $opt->{type} eq 'm' ) { # type time
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
if ( !$suffix ) {
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
$suffix = $s || 's';
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
$opt->{long}, '(value:', $val, ')');
}
if ( $suffix =~ m/[smhd]/ ) {
$val = $suffix eq 's' ? $num # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$opt->{value} = ($prefix || '') . $val;
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
}
else {
$self->save_error("Invalid time suffix for --$opt->{long}");
}
}
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
$from_key, 'parsed');
return;
}
}
my $defaults = $self->{DSNParser}->parse_options($self);
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
}
elsif ( $val && $opt->{type} eq 'z' ) { # type size
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
$self->_parse_size($opt, $val);
}
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
$opt->{value} = { map { $_ => 1 } split(/(?{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
$opt->{value} = [ split(/(?{long}, 'type', $opt->{type}, 'value', $val);
}
$opt->{parsed} = 1;
return;
}
sub get {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{value};
}
sub got {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{got};
}
sub has {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
return defined $long ? exists $self->{opts}->{$long} : 0;
}
sub set {
my ( $self, $opt, $val ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
$self->{opts}->{$long}->{value} = $val;
return;
}
sub save_error {
my ( $self, $error ) = @_;
push @{$self->{errors}}, $error;
return;
}
sub errors {
my ( $self ) = @_;
return $self->{errors};
}
sub usage {
my ( $self ) = @_;
warn "No usage string is set" unless $self->{usage}; # XXX
return "Usage: " . ($self->{usage} || '') . "\n";
}
sub descr {
my ( $self ) = @_;
warn "No description string is set" unless $self->{description}; # XXX
my $descr = ($self->{description} || $self->{program_name} || '')
. " For more details, please use the --help option, "
. "or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation.";
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
unless $ENV{DONT_BREAK_LINES};
$descr =~ s/ +$//mg;
return $descr;
}
sub usage_or_errors {
my ( $self, $file, $return ) = @_;
$file ||= $self->{file} || __FILE__;
if ( !$self->{description} || !$self->{usage} ) {
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
PTDEBUG && _d("Description:", $self->{description},
"\nUsage:", $self->{usage});
}
if ( $self->{opts}->{help}->{got} ) {
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
exit 0 unless $return;
}
elsif ( scalar @{$self->{errors}} ) {
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
exit 1 unless $return;
}
return;
}
sub print_errors {
my ( $self ) = @_;
my $usage = $self->usage() . "\n";
if ( (my @errors = @{$self->{errors}}) ) {
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
. "\n";
}
return $usage . "\n" . $self->descr();
}
sub print_usage {
my ( $self ) = @_;
die "Run get_opts() before print_usage()" unless $self->{got_opts};
my @opts = values %{$self->{opts}};
my $maxl = max(
map {
length($_->{long}) # option long name
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
}
@opts);
my $maxs = max(0,
map {
length($_)
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
}
values %{$self->{short_opts}});
my $lcol = max($maxl, ($maxs + 3));
my $rcol = 80 - $lcol - 6;
my $rpad = ' ' x ( 80 - $rcol );
$maxs = max($lcol - 3, $maxs);
my $usage = $self->descr() . "\n" . $self->usage();
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
push @groups, 'default';
foreach my $group ( reverse @groups ) {
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
foreach my $opt (
sort { $a->{long} cmp $b->{long} }
grep { $_->{group} eq $group }
@opts )
{
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
my $short = $opt->{short};
my $desc = $opt->{desc};
$long .= $opt->{type} ? "=$opt->{type}" : "";
if ( $opt->{type} && $opt->{type} eq 'm' ) {
my ($s) = $desc =~ m/\(suffix (.)\)/;
$s ||= 's';
$desc =~ s/\s+\(suffix .\)//;
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
. "d=days; if no suffix, $s is used.";
}
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
$desc =~ s/ +$//mg;
if ( $short ) {
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
}
else {
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
}
}
}
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
if ( (my @rules = @{$self->{rules}}) ) {
$usage .= "\nRules:\n\n";
$usage .= join("\n", map { " $_" } @rules) . "\n";
}
if ( $self->{DSNParser} ) {
$usage .= "\n" . $self->{DSNParser}->usage();
}
$usage .= "\nOptions and values after processing arguments:\n\n";
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
my $val = $opt->{value};
my $type = $opt->{type} || '';
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
: !defined $val ? '(No value)'
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
: $type =~ m/H|h/ ? join(',', sort keys %$val)
: $type =~ m/A|a/ ? join(',', @$val)
: $val;
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
}
return $usage;
}
sub prompt_noecho {
shift @_ if ref $_[0] eq __PACKAGE__;
my ( $prompt ) = @_;
local $OUTPUT_AUTOFLUSH = 1;
print STDERR $prompt
or die "Cannot print: $OS_ERROR";
my $response;
eval {
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
chomp($response = );
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& !$self->has('version-check')
&& $line =~ /version-check/
) {
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# TableParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/TableParser.pm
# t/lib/TableParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package TableParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
local $EVAL_ERROR;
eval {
require Quoter;
};
sub new {
my ( $class, %args ) = @_;
my $self = { %args };
$self->{Quoter} ||= Quoter->new();
return bless $self, $class;
}
sub Quoter { shift->{Quoter} }
sub get_create_table {
my ( $self, $dbh, $db, $tbl ) = @_;
die "I need a dbh parameter" unless $dbh;
die "I need a db parameter" unless $db;
die "I need a tbl parameter" unless $tbl;
my $q = $self->{Quoter};
my $new_sql_mode
= q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, }
. q{@@SQL_MODE := '', }
. q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, }
. q{@@SQL_QUOTE_SHOW_CREATE := 1 */};
my $old_sql_mode
= q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, }
. q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */};
PTDEBUG && _d($new_sql_mode);
eval { $dbh->do($new_sql_mode); };
PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
my $use_sql = 'USE ' . $q->quote($db);
PTDEBUG && _d($dbh, $use_sql);
$dbh->do($use_sql);
my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
PTDEBUG && _d($show_sql);
my $href;
eval { $href = $dbh->selectrow_hashref($show_sql); };
if ( my $e = $EVAL_ERROR ) {
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
die $e;
}
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
my ($key) = grep { m/create (?:table|view)/i } keys %$href;
if ( !$key ) {
die "Error: no 'Create Table' or 'Create View' in result set from "
. "$show_sql: " . Dumper($href);
}
return $href->{$key};
}
sub parse {
my ( $self, $ddl, $opts ) = @_;
return unless $ddl;
if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
$ddl = $self->ansi_to_legacy($ddl);
}
elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
die "TableParser doesn't handle CREATE TABLE without quoting.";
}
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
$ddl =~ s/(`[^`]+`)/\L$1/g;
my $engine = $self->get_engine($ddl);
my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
PTDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
my %def_for;
@def_for{@cols} = @defs;
my (@nums, @null);
my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
foreach my $col ( @cols ) {
my $def = $def_for{$col};
$def =~ s/``//g;
my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
die "Can't determine column type for $def" unless $type;
$type_for{$col} = $type;
if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
push @nums, $col;
$is_numeric{$col} = 1;
}
if ( $def !~ m/NOT NULL/ ) {
push @null, $col;
$is_nullable{$col} = 1;
}
$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
}
my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
return {
name => $name,
cols => \@cols,
col_posn => { map { $cols[$_] => $_ } 0..$#cols },
is_col => { map { $_ => 1 } @cols },
null_cols => \@null,
is_nullable => \%is_nullable,
is_autoinc => \%is_autoinc,
clustered_key => $clustered_key,
keys => $keys,
defs => \%def_for,
numeric_cols => \@nums,
is_numeric => \%is_numeric,
engine => $engine,
type_for => \%type_for,
charset => $charset,
};
}
sub sort_indexes {
my ( $self, $tbl ) = @_;
my @indexes
= sort {
(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
|| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
|| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
|| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
}
grep {
$tbl->{keys}->{$_}->{type} eq 'BTREE'
}
sort keys %{$tbl->{keys}};
PTDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
return @indexes;
}
sub find_best_index {
my ( $self, $tbl, $index ) = @_;
my $best;
if ( $index ) {
($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
}
if ( !$best ) {
if ( $index ) {
die "Index '$index' does not exist in table";
}
else {
($best) = $self->sort_indexes($tbl);
}
}
PTDEBUG && _d('Best index found is', $best);
return $best;
}
sub find_possible_keys {
my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
return () unless $where;
my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
. ' WHERE ' . $where;
PTDEBUG && _d($sql);
my $expl = $dbh->selectrow_hashref($sql);
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
if ( $expl->{possible_keys} ) {
PTDEBUG && _d('possible_keys =', $expl->{possible_keys});
my @candidates = split(',', $expl->{possible_keys});
my %possible = map { $_ => 1 } @candidates;
if ( $expl->{key} ) {
PTDEBUG && _d('MySQL chose', $expl->{key});
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
PTDEBUG && _d('Before deduping:', join(', ', @candidates));
my %seen;
@candidates = grep { !$seen{$_}++ } @candidates;
}
PTDEBUG && _d('Final list:', join(', ', @candidates));
return @candidates;
}
else {
PTDEBUG && _d('No keys in possible_keys');
return ();
}
}
sub check_table {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl) = @args{@required_args};
my $q = $self->{Quoter} || 'Quoter';
my $db_tbl = $q->quote($db, $tbl);
PTDEBUG && _d('Checking', $db_tbl);
my $sql = "SHOW TABLES FROM " . $q->quote($db)
. ' LIKE ' . $q->literal_like($tbl);
PTDEBUG && _d($sql);
my $row;
eval {
$row = $dbh->selectrow_arrayref($sql);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
return 0;
}
if ( !$row->[0] || $row->[0] ne $tbl ) {
PTDEBUG && _d('Table does not exist');
return 0;
}
PTDEBUG && _d('Table', $db, $tbl, 'exists');
return 1;
}
sub get_engine {
my ( $self, $ddl, $opts ) = @_;
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
PTDEBUG && _d('Storage engine:', $engine);
return $engine || undef;
}
sub get_keys {
my ( $self, $ddl, $opts, $is_nullable ) = @_;
my $engine = $self->get_engine($ddl);
my $keys = {};
my $clustered_key = undef;
KEY:
foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
next KEY if $key =~ m/FOREIGN/;
my $key_ddl = $key;
PTDEBUG && _d('Parsed key:', $key_ddl);
if ( !$engine || $engine !~ m/MEMORY|HEAP/ ) {
$key =~ s/USING HASH/USING BTREE/;
}
my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
$type = $type || $special || 'BTREE';
my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
my @cols;
my @col_prefixes;
foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
push @cols, $name;
push @col_prefixes, $prefix;
}
$name =~ s/`//g;
PTDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
$keys->{$name} = {
name => $name,
type => $type,
colnames => $cols,
cols => \@cols,
col_prefixes => \@col_prefixes,
is_unique => $unique,
is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
is_col => { map { $_ => 1 } @cols },
ddl => $key_ddl,
};
if ( ($engine || '') =~ m/InnoDB/i && !$clustered_key ) {
my $this_key = $keys->{$name};
if ( $this_key->{name} eq 'PRIMARY' ) {
$clustered_key = 'PRIMARY';
}
elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
$clustered_key = $this_key->{name};
}
PTDEBUG && $clustered_key && _d('This key is the clustered key');
}
}
return $keys, $clustered_key;
}
sub get_fks {
my ( $self, $ddl, $opts ) = @_;
my $q = $self->{Quoter};
my $fks = {};
foreach my $fk (
$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
{
my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
my ($db, $tbl) = $q->split_unquote($parent, $opts->{database});
my %parent_tbl = (tbl => $tbl);
$parent_tbl{db} = $db if $db;
if ( $parent !~ m/\./ && $opts->{database} ) {
$parent = $q->quote($opts->{database}) . ".$parent";
}
$fks->{$name} = {
name => $name,
colnames => $cols,
cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
parent_tbl => \%parent_tbl,
parent_tblname => $parent,
parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
parent_colnames=> $parent_cols,
ddl => $fk,
};
}
return $fks;
}
sub remove_auto_increment {
my ( $self, $ddl ) = @_;
$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
return $ddl;
}
sub get_table_status {
my ( $self, $dbh, $db, $like ) = @_;
my $q = $self->{Quoter};
my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
PTDEBUG && _d($sql, @params);
my $sth = $dbh->prepare($sql);
eval { $sth->execute(@params); };
if ($EVAL_ERROR) {
PTDEBUG && _d($EVAL_ERROR);
return;
}
my @tables = @{$sth->fetchall_arrayref({})};
@tables = map {
my %tbl; # Make a copy with lowercased keys
@tbl{ map { lc $_ } keys %$_ } = values %$_;
$tbl{engine} ||= $tbl{type} || $tbl{comment};
delete $tbl{type};
\%tbl;
} @tables;
return @tables;
}
my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx;
sub ansi_to_legacy {
my ($self, $ddl) = @_;
$ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge;
return $ddl;
}
sub ansi_quote_replace {
my ($val) = @_;
$val =~ s/^"|"$//g;
$val =~ s/`/``/g;
$val =~ s/""/"/g;
return "`$val`";
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TableParser package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# VersionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionParser.pm
# t/lib/VersionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionParser;
use Lmo;
use Scalar::Util qw(blessed);
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use overload (
'""' => "version",
'<=>' => "cmp",
'cmp' => "cmp",
fallback => 1,
);
use Carp ();
our $VERSION = 0.01;
has major => (
is => 'ro',
isa => 'Int',
required => 1,
);
has [qw( minor revision )] => (
is => 'ro',
isa => 'Num',
);
has flavor => (
is => 'ro',
isa => 'Str',
default => sub { 'Unknown' },
);
has innodb_version => (
is => 'ro',
isa => 'Str',
default => sub { 'NO' },
);
sub series {
my $self = shift;
return $self->_join_version($self->major, $self->minor);
}
sub version {
my $self = shift;
return $self->_join_version($self->major, $self->minor, $self->revision);
}
sub is_in {
my ($self, $target) = @_;
return $self eq $target;
}
sub _join_version {
my ($self, @parts) = @_;
return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
}
sub _split_version {
my ($self, $str) = @_;
my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
return @version_parts[0..2];
}
sub normalized_version {
my ( $self ) = @_;
my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
$self->minor,
$self->revision);
PTDEBUG && _d($self->version, 'normalizes to', $result);
return $result;
}
sub comment {
my ( $self, $cmd ) = @_;
my $v = $self->normalized_version();
return "/*!$v $cmd */"
}
my @methods = qw(major minor revision);
sub cmp {
my ($left, $right) = @_;
my $right_obj = (blessed($right) && $right->isa(ref($left)))
? $right
: ref($left)->new($right);
my $retval = 0;
for my $m ( @methods ) {
last unless defined($left->$m) && defined($right_obj->$m);
$retval = $left->$m <=> $right_obj->$m;
last if $retval;
}
return $retval;
}
sub BUILDARGS {
my $self = shift;
if ( @_ == 1 ) {
my %args;
if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
my $dbh = $_[0];
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $query = eval {
$dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
};
if ( $query ) {
$query = { map { $_->{variable_name} => $_->{value} } @$query };
@args{@methods} = $self->_split_version($query->{version});
$args{flavor} = delete $query->{version_comment}
if $query->{version_comment};
}
elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
@args{@methods} = $self->_split_version($query);
}
else {
Carp::confess("Couldn't get the version from the dbh while "
. "creating a VersionParser object: $@");
}
$args{innodb_version} = eval { $self->_innodb_version($dbh) };
}
elsif ( !ref($_[0]) ) {
@args{@methods} = $self->_split_version($_[0]);
}
for my $method (@methods) {
delete $args{$method} unless defined $args{$method};
}
@_ = %args if %args;
}
return $self->SUPER::BUILDARGS(@_);
}
sub _innodb_version {
my ( $self, $dbh ) = @_;
return unless $dbh;
my $innodb_version = "NO";
my ($innodb) =
grep { $_->{engine} =~ m/InnoDB/i }
map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
if ( $innodb ) {
PTDEBUG && _d("InnoDB support:", $innodb->{support});
if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
my $vars = $dbh->selectrow_hashref(
"SHOW VARIABLES LIKE 'innodb_version'");
$innodb_version = !$vars ? "BUILTIN"
: ($vars->{Value} || $vars->{value});
}
else {
$innodb_version = $innodb->{support}; # probably DISABLED or NO
}
}
PTDEBUG && _d("InnoDB version:", $innodb_version);
return $innodb_version;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
no Lmo;
1;
}
# ###########################################################################
# End VersionParser package
# ###########################################################################
# ###########################################################################
# Quoter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Quoter.pm
# t/lib/Quoter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Quoter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
return bless {}, $class;
}
sub quote {
my ( $self, @vals ) = @_;
foreach my $val ( @vals ) {
$val =~ s/`/``/g;
}
return join('.', map { '`' . $_ . '`' } @vals);
}
sub quote_val {
my ( $self, $val, %args ) = @_;
return 'NULL' unless defined $val; # undef = NULL
return "''" if $val eq ''; # blank string = ''
return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
&& !$args{is_char}; # unless is_char is true
$val =~ s/(['\\])/\\$1/g;
return "'$val'";
}
sub split_unquote {
my ( $self, $db_tbl, $default_db ) = @_;
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
for ($db, $tbl) {
next unless $_;
s/\A`//;
s/`\z//;
s/``/`/g;
}
return ($db, $tbl);
}
sub literal_like {
my ( $self, $like ) = @_;
return unless $like;
$like =~ s/([%_])/\\$1/g;
return "'$like'";
}
sub join_quote {
my ( $self, $default_db, $db_tbl ) = @_;
return unless $db_tbl;
my ($db, $tbl) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
$db = "`$db`" if $db && $db !~ m/^`/;
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
return $db ? "$db.$tbl" : $tbl;
}
sub serialize_list {
my ( $self, @args ) = @_;
PTDEBUG && _d('Serializing', Dumper(\@args));
return unless @args;
my @parts;
foreach my $arg ( @args ) {
if ( defined $arg ) {
$arg =~ s/,/\\,/g; # escape commas
$arg =~ s/\\N/\\\\N/g; # escape literal \N
push @parts, $arg;
}
else {
push @parts, '\N';
}
}
my $string = join(',', @parts);
PTDEBUG && _d('Serialized: <', $string, '>');
return $string;
}
sub deserialize_list {
my ( $self, $string ) = @_;
PTDEBUG && _d('Deserializing <', $string, '>');
die "Cannot deserialize an undefined string" unless defined $string;
my @parts;
foreach my $arg ( split(/(? 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(TableParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = { %args };
return bless $self, $class;
}
sub generate_asc_stmt {
my ( $self, %args ) = @_;
my @required_args = qw(tbl_struct index);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($tbl_struct, $index) = @args{@required_args};
my @cols = $args{cols} ? @{$args{cols}} : @{$tbl_struct->{cols}};
my $q = $self->{Quoter};
die "Index '$index' does not exist in table"
unless exists $tbl_struct->{keys}->{$index};
PTDEBUG && _d('Will ascend index', $index);
my @asc_cols = @{$tbl_struct->{keys}->{$index}->{cols}};
if ( $args{asc_first} ) {
PTDEBUG && _d('Ascending only first column');
@asc_cols = $asc_cols[0];
}
elsif ( my $n = $args{n_index_cols} ) {
$n = scalar @asc_cols if $n > @asc_cols;
PTDEBUG && _d('Ascending only first', $n, 'columns');
@asc_cols = @asc_cols[0..($n-1)];
}
PTDEBUG && _d('Will ascend columns', join(', ', @asc_cols));
my @asc_slice;
my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
foreach my $col ( @asc_cols ) {
if ( !exists $col_posn{$col} ) {
push @cols, $col;
$col_posn{$col} = $#cols;
}
push @asc_slice, $col_posn{$col};
}
PTDEBUG && _d('Will ascend, in ordinal position:', join(', ', @asc_slice));
my $asc_stmt = {
cols => \@cols,
index => $index,
where => '',
slice => [],
scols => [],
};
if ( @asc_slice ) {
my $cmp_where;
foreach my $cmp ( qw(< <= >= >) ) {
$cmp_where = $self->generate_cmp_where(
type => $cmp,
slice => \@asc_slice,
cols => \@cols,
quoter => $q,
is_nullable => $tbl_struct->{is_nullable},
);
$asc_stmt->{boundaries}->{$cmp} = $cmp_where->{where};
}
my $cmp = $args{asc_only} ? '>' : '>=';
$asc_stmt->{where} = $asc_stmt->{boundaries}->{$cmp};
$asc_stmt->{slice} = $cmp_where->{slice};
$asc_stmt->{scols} = $cmp_where->{scols};
}
return $asc_stmt;
}
sub generate_cmp_where {
my ( $self, %args ) = @_;
foreach my $arg ( qw(type slice cols is_nullable) ) {
die "I need a $arg arg" unless defined $args{$arg};
}
my @slice = @{$args{slice}};
my @cols = @{$args{cols}};
my $is_nullable = $args{is_nullable};
my $type = $args{type};
my $q = $self->{Quoter};
(my $cmp = $type) =~ s/=//;
my @r_slice; # Resulting slice columns, by ordinal
my @r_scols; # Ditto, by name
my @clauses;
foreach my $i ( 0 .. $#slice ) {
my @clause;
foreach my $j ( 0 .. $i - 1 ) {
my $ord = $slice[$j];
my $col = $cols[$ord];
my $quo = $q->quote($col);
if ( $is_nullable->{$col} ) {
push @clause, "((? IS NULL AND $quo IS NULL) OR ($quo = ?))";
push @r_slice, $ord, $ord;
push @r_scols, $col, $col;
}
else {
push @clause, "$quo = ?";
push @r_slice, $ord;
push @r_scols, $col;
}
}
my $ord = $slice[$i];
my $col = $cols[$ord];
my $quo = $q->quote($col);
my $end = $i == $#slice; # Last clause of the whole group.
if ( $is_nullable->{$col} ) {
if ( $type =~ m/=/ && $end ) {
push @clause, "(? IS NULL OR $quo $type ?)";
}
elsif ( $type =~ m/>/ ) {
push @clause, "((? IS NULL AND $quo IS NOT NULL) OR ($quo $cmp ?))";
}
else { # If $type =~ m/ \@r_slice,
scols => \@r_scols,
where => $result,
};
return $where;
}
sub generate_del_stmt {
my ( $self, %args ) = @_;
my $tbl = $args{tbl_struct};
my @cols = $args{cols} ? @{$args{cols}} : ();
my $tp = $self->{TableParser};
my $q = $self->{Quoter};
my @del_cols;
my @del_slice;
my $index = $tp->find_best_index($tbl, $args{index});
die "Cannot find an ascendable index in table" unless $index;
if ( $index ) {
@del_cols = @{$tbl->{keys}->{$index}->{cols}};
}
else {
@del_cols = @{$tbl->{cols}};
}
PTDEBUG && _d('Columns needed for DELETE:', join(', ', @del_cols));
my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
foreach my $col ( @del_cols ) {
if ( !exists $col_posn{$col} ) {
push @cols, $col;
$col_posn{$col} = $#cols;
}
push @del_slice, $col_posn{$col};
}
PTDEBUG && _d('Ordinals needed for DELETE:', join(', ', @del_slice));
my $del_stmt = {
cols => \@cols,
index => $index,
where => '',
slice => [],
scols => [],
};
my @clauses;
foreach my $i ( 0 .. $#del_slice ) {
my $ord = $del_slice[$i];
my $col = $cols[$ord];
my $quo = $q->quote($col);
if ( $tbl->{is_nullable}->{$col} ) {
push @clauses, "((? IS NULL AND $quo IS NULL) OR ($quo = ?))";
push @{$del_stmt->{slice}}, $ord, $ord;
push @{$del_stmt->{scols}}, $col, $col;
}
else {
push @clauses, "$quo = ?";
push @{$del_stmt->{slice}}, $ord;
push @{$del_stmt->{scols}}, $col;
}
}
$del_stmt->{where} = '(' . join(' AND ', @clauses) . ')';
return $del_stmt;
}
sub generate_ins_stmt {
my ( $self, %args ) = @_;
foreach my $arg ( qw(ins_tbl sel_cols) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $ins_tbl = $args{ins_tbl};
my @sel_cols = @{$args{sel_cols}};
die "You didn't specify any SELECT columns" unless @sel_cols;
my @ins_cols;
my @ins_slice;
for my $i ( 0..$#sel_cols ) {
next unless $ins_tbl->{is_col}->{$sel_cols[$i]};
push @ins_cols, $sel_cols[$i];
push @ins_slice, $i;
}
return {
cols => \@ins_cols,
slice => \@ins_slice,
};
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TableNibbler package
# ###########################################################################
# ###########################################################################
# Daemon package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Daemon.pm
# t/lib/Daemon.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Daemon;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(setsid);
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(o) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $o = $args{o};
my $self = {
o => $o,
log_file => $o->has('log') ? $o->get('log') : undef,
PID_file => $o->has('pid') ? $o->get('pid') : undef,
};
check_PID_file(undef, $self->{PID_file});
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
return bless $self, $class;
}
sub daemonize {
my ( $self ) = @_;
PTDEBUG && _d('About to fork and daemonize');
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $pid ) {
PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
exit;
}
PTDEBUG && _d('Daemonizing child PID', $PID);
$self->{PID_owner} = $PID;
$self->{child} = 1;
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
$self->_make_PID_file();
$OUTPUT_AUTOFLUSH = 1;
PTDEBUG && _d('Redirecting STDIN to /dev/null');
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
if ( $self->{log_file} ) {
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
close STDOUT;
open STDOUT, '>>', $self->{log_file}
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
close STDERR;
open STDERR, ">&STDOUT"
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
}
else {
if ( -t STDOUT ) {
PTDEBUG && _d('No log file and STDOUT is a terminal;',
'redirecting to /dev/null');
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
PTDEBUG && _d('No log file and STDERR is a terminal;',
'redirecting to /dev/null');
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
return;
}
sub check_PID_file {
my ( $self, $file ) = @_;
my $PID_file = $self ? $self->{PID_file} : $file;
PTDEBUG && _d('Checking PID file', $PID_file);
if ( $PID_file && -f $PID_file ) {
my $pid;
eval {
chomp($pid = (slurp_file($PID_file) || ''));
};
if ( $EVAL_ERROR ) {
die "The PID file $PID_file already exists but it cannot be read: "
. $EVAL_ERROR;
}
PTDEBUG && _d('PID file exists; it contains PID', $pid);
if ( $pid ) {
my $pid_is_alive = kill 0, $pid;
if ( $pid_is_alive ) {
die "The PID file $PID_file already exists "
. " and the PID that it contains, $pid, is running";
}
else {
warn "Overwriting PID file $PID_file because the PID that it "
. "contains, $pid, is not running";
}
}
else {
die "The PID file $PID_file already exists but it does not "
. "contain a PID";
}
}
else {
PTDEBUG && _d('No PID file');
}
return;
}
sub make_PID_file {
my ( $self ) = @_;
if ( exists $self->{child} ) {
die "Do not call Daemon::make_PID_file() for daemonized scripts";
}
$self->_make_PID_file();
$self->{PID_owner} = $PID;
return;
}
sub _make_PID_file {
my ( $self ) = @_;
my $PID_file = $self->{PID_file};
if ( !$PID_file ) {
PTDEBUG && _d('No PID file to create');
return;
}
$self->check_PID_file();
open my $PID_FH, '>', $PID_file
or die "Cannot open PID file $PID_file: $OS_ERROR";
print $PID_FH $PID
or die "Cannot print to PID file $PID_file: $OS_ERROR";
close $PID_FH
or die "Cannot close PID file $PID_file: $OS_ERROR";
PTDEBUG && _d('Created PID file:', $self->{PID_file});
return;
}
sub _remove_PID_file {
my ( $self ) = @_;
if ( $self->{PID_file} && -f $self->{PID_file} ) {
unlink $self->{PID_file}
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
PTDEBUG && _d('Removed PID file');
}
else {
PTDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ( $self ) = @_;
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
return;
}
sub slurp_file {
my ($file) = @_;
return unless $file;
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
return do { local $/; <$fh> };
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Daemon package
# ###########################################################################
# ###########################################################################
# MasterSlave package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MasterSlave.pm
# t/lib/MasterSlave.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MasterSlave;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub check_recursion_method {
my ($methods) = @_;
if ( @$methods != 1 ) {
if ( grep({ !m/processlist|hosts/i } @$methods)
&& $methods->[0] !~ /^dsn=/i )
{
die "Invalid combination of recursion methods: "
. join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". "
. "Only hosts and processlist may be combined.\n"
}
}
else {
my ($method) = @$methods;
die "Invalid recursion method: " . ( $method || 'undef' )
unless $method && $method =~ m/^(?:processlist$|hosts$|none$|dsn=)/i;
}
}
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(OptionParser DSNParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
%args,
replication_thread => {},
};
return bless $self, $class;
}
sub get_slaves {
my ($self, %args) = @_;
my @required_args = qw(make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($make_cxn) = @args{@required_args};
my $slaves = [];
my $dp = $self->{DSNParser};
my $methods = $self->_resolve_recursion_methods($args{dsn});
return $slaves unless @$methods;
if ( grep { m/processlist|hosts/i } @$methods ) {
my @required_args = qw(dbh dsn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $dsn) = @args{@required_args};
$self->recurse_to_slaves(
{ dbh => $dbh,
dsn => $dsn,
callback => sub {
my ( $dsn, $dbh, $level, $parent ) = @_;
return unless $level;
PTDEBUG && _d('Found slave:', $dp->as_string($dsn));
push @$slaves, $make_cxn->(dsn => $dsn, dbh => $dbh);
return;
},
}
);
}
elsif ( $methods->[0] =~ m/^dsn=/i ) {
(my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i;
$slaves = $self->get_cxn_from_dsn_table(
%args,
dsn_table_dsn => $dsn_table_dsn,
);
}
elsif ( $methods->[0] =~ m/none/i ) {
PTDEBUG && _d('Not getting to slaves');
}
else {
die "Unexpected recursion methods: @$methods";
}
return $slaves;
}
sub _resolve_recursion_methods {
my ($self, $dsn) = @_;
my $o = $self->{OptionParser};
if ( $o->got('recursion-method') ) {
return $o->get('recursion-method');
}
elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) {
PTDEBUG && _d('Port number is non-standard; using only hosts method');
return [qw(hosts)];
}
else {
return $o->get('recursion-method');
}
}
sub recurse_to_slaves {
my ( $self, $args, $level ) = @_;
$level ||= 0;
my $dp = $self->{DSNParser};
my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse');
my $dsn = $args->{dsn};
my $methods = $self->_resolve_recursion_methods($dsn);
PTDEBUG && _d('Recursion methods:', @$methods);
if ( lc($methods->[0]) eq 'none' ) {
PTDEBUG && _d('Not recursing to slaves');
return;
}
my $dbh;
eval {
$dbh = $args->{dbh} || $dp->get_dbh(
$dp->get_cxn_params($dsn), { AutoCommit => 1 });
PTDEBUG && _d('Connected to', $dp->as_string($dsn));
};
if ( $EVAL_ERROR ) {
print STDERR "Cannot connect to ", $dp->as_string($dsn), "\n"
or die "Cannot print: $OS_ERROR";
return;
}
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
my ($id) = $dbh->selectrow_array($sql);
PTDEBUG && _d('Working on server ID', $id);
my $master_thinks_i_am = $dsn->{server_id};
if ( !defined $id
|| ( defined $master_thinks_i_am && $master_thinks_i_am != $id )
|| $args->{server_ids_seen}->{$id}++
) {
PTDEBUG && _d('Server ID seen, or not what master said');
if ( $args->{skip_callback} ) {
$args->{skip_callback}->($dsn, $dbh, $level, $args->{parent});
}
return;
}
$args->{callback}->($dsn, $dbh, $level, $args->{parent});
if ( !defined $recurse || $level < $recurse ) {
my @slaves =
grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves.
$self->find_slave_hosts($dp, $dbh, $dsn, $methods);
foreach my $slave ( @slaves ) {
PTDEBUG && _d('Recursing from',
$dp->as_string($dsn), 'to', $dp->as_string($slave));
$self->recurse_to_slaves(
{ %$args, dsn => $slave, dbh => undef, parent => $dsn }, $level + 1 );
}
}
}
sub find_slave_hosts {
my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_;
PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn),
'using methods', @$methods);
my @slaves;
METHOD:
foreach my $method ( @$methods ) {
my $find_slaves = "_find_slaves_by_$method";
PTDEBUG && _d('Finding slaves with', $find_slaves);
@slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn);
last METHOD if @slaves;
}
PTDEBUG && _d('Found', scalar(@slaves), 'slaves');
return @slaves;
}
sub _find_slaves_by_processlist {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves = map {
my $slave = $dsn_parser->parse("h=$_", $dsn);
$slave->{source} = 'processlist';
$slave;
}
grep { $_ }
map {
my ( $host ) = $_->{host} =~ m/^([^:]+):/;
if ( $host eq 'localhost' ) {
$host = '127.0.0.1'; # Replication never uses sockets.
}
$host;
} $self->get_connected_slaves($dbh);
return @slaves;
}
sub _find_slaves_by_hosts {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves;
my $sql = 'SHOW SLAVE HOSTS';
PTDEBUG && _d($dbh, $sql);
@slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })};
if ( @slaves ) {
PTDEBUG && _d('Found some SHOW SLAVE HOSTS info');
@slaves = map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
my $spec = "h=$hash{host},P=$hash{port}"
. ( $hash{user} ? ",u=$hash{user}" : '')
. ( $hash{password} ? ",p=$hash{password}" : '');
my $dsn = $dsn_parser->parse($spec, $dsn);
$dsn->{server_id} = $hash{server_id};
$dsn->{master_id} = $hash{master_id};
$dsn->{source} = 'hosts';
$dsn;
} @slaves;
}
return @slaves;
}
sub get_connected_slaves {
my ( $self, $dbh ) = @_;
my $show = "SHOW GRANTS FOR ";
my $user = 'CURRENT_USER()';
my $sql = $show . $user;
PTDEBUG && _d($dbh, $sql);
my $proc;
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
if ( $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) {
PTDEBUG && _d('Retrying SHOW GRANTS without host; error:',
$EVAL_ERROR);
($user) = split('@', $user);
$sql = $show . $user;
PTDEBUG && _d($sql);
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
}
die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR;
}
if ( !$proc ) {
die "You do not have the PROCESS privilege";
}
$sql = 'SHOW PROCESSLIST';
PTDEBUG && _d($dbh, $sql);
grep { $_->{command} =~ m/Binlog Dump/i }
map { # Lowercase the column names
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{$dbh->selectall_arrayref($sql, { Slice => {} })};
}
sub is_master_of {
my ( $self, $master, $slave ) = @_;
my $master_status = $self->get_master_status($master)
or die "The server specified as a master is not a master";
my $slave_status = $self->get_slave_status($slave)
or die "The server specified as a slave is not a slave";
my @connected = $self->get_connected_slaves($master)
or die "The server specified as a master has no connected slaves";
my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'");
if ( $port != $slave_status->{master_port} ) {
die "The slave is connected to $slave_status->{master_port} "
. "but the master's port is $port";
}
if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) {
die "I don't see any slave I/O thread connected with user "
. $slave_status->{master_user};
}
if ( ($slave_status->{slave_io_state} || '')
eq 'Waiting for master to send event' )
{
my ( $master_log_name, $master_log_num )
= $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
my ( $slave_log_name, $slave_log_num )
= $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
if ( $master_log_name ne $slave_log_name
|| abs($master_log_num - $slave_log_num) > 1 )
{
die "The slave thinks it is reading from "
. "$slave_status->{master_log_file}, but the "
. "master is writing to $master_status->{file}";
}
}
return 1;
}
sub get_master_dsn {
my ( $self, $dbh, $dsn, $dsn_parser ) = @_;
my $master = $self->get_slave_status($dbh) or return undef;
my $spec = "h=$master->{master_host},P=$master->{master_port}";
return $dsn_parser->parse($spec, $dsn);
}
sub get_slave_status {
my ( $self, $dbh ) = @_;
if ( !$self->{not_a_slave}->{$dbh} ) {
my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS}
||= $dbh->prepare('SHOW SLAVE STATUS');
PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS');
$sth->execute();
my ($ss) = @{$sth->fetchall_arrayref({})};
if ( $ss && %$ss ) {
$ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys
return $ss;
}
PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS');
$self->{not_a_slave}->{$dbh}++;
}
}
sub get_master_status {
my ( $self, $dbh ) = @_;
if ( $self->{not_a_master}->{$dbh} ) {
PTDEBUG && _d('Server on dbh', $dbh, 'is not a master');
return;
}
my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS}
||= $dbh->prepare('SHOW MASTER STATUS');
PTDEBUG && _d($dbh, 'SHOW MASTER STATUS');
$sth->execute();
my ($ms) = @{$sth->fetchall_arrayref({})};
PTDEBUG && _d(
$ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms
: '');
if ( !$ms || scalar keys %$ms < 2 ) {
PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master');
$self->{not_a_master}->{$dbh}++;
}
return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys
}
sub wait_for_master {
my ( $self, %args ) = @_;
my @required_args = qw(master_status slave_dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($master_status, $slave_dbh) = @args{@required_args};
my $timeout = $args{timeout} || 60;
my $result;
my $waited;
if ( $master_status ) {
my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', "
. "$master_status->{position}, $timeout)";
PTDEBUG && _d($slave_dbh, $sql);
my $start = time;
($result) = $slave_dbh->selectrow_array($sql);
$waited = time - $start;
PTDEBUG && _d('Result of waiting:', $result);
PTDEBUG && _d("Waited", $waited, "seconds");
}
else {
PTDEBUG && _d('Not waiting: this server is not a master');
}
return {
result => $result,
waited => $waited,
};
}
sub stop_slave {
my ( $self, $dbh ) = @_;
my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE}
||= $dbh->prepare('STOP SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
sub start_slave {
my ( $self, $dbh, $pos ) = @_;
if ( $pos ) {
my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', "
. "MASTER_LOG_POS=$pos->{position}";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
else {
my $sth = $self->{sths}->{$dbh}->{START_SLAVE}
||= $dbh->prepare('START SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
}
sub catchup_to_master {
my ( $self, $slave, $master, $timeout ) = @_;
$self->stop_slave($master);
$self->stop_slave($slave);
my $slave_status = $self->get_slave_status($slave);
my $slave_pos = $self->repl_posn($slave_status);
my $master_status = $self->get_master_status($master);
my $master_pos = $self->repl_posn($master_status);
PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
my $result;
if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) {
PTDEBUG && _d('Waiting for slave to catch up to master');
$self->start_slave($slave, $master_pos);
$result = $self->wait_for_master(
master_status => $master_status,
slave_dbh => $slave,
timeout => $timeout,
master_status => $master_status
);
if ( !defined $result->{result} ) {
$slave_status = $self->get_slave_status($slave);
if ( !$self->slave_is_running($slave_status) ) {
PTDEBUG && _d('Master position:',
$self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
$slave_pos = $self->repl_posn($slave_status);
if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) {
die "MASTER_POS_WAIT() returned NULL but slave has not "
. "caught up to master";
}
PTDEBUG && _d('Slave is caught up to master and stopped');
}
else {
die "Slave has not caught up to master and it is still running";
}
}
}
else {
PTDEBUG && _d("Slave is already caught up to master");
}
return $result;
}
sub catchup_to_same_pos {
my ( $self, $s1_dbh, $s2_dbh ) = @_;
$self->stop_slave($s1_dbh);
$self->stop_slave($s2_dbh);
my $s1_status = $self->get_slave_status($s1_dbh);
my $s2_status = $self->get_slave_status($s2_dbh);
my $s1_pos = $self->repl_posn($s1_status);
my $s2_pos = $self->repl_posn($s2_status);
if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) {
$self->start_slave($s1_dbh, $s2_pos);
}
elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) {
$self->start_slave($s2_dbh, $s1_pos);
}
$s1_status = $self->get_slave_status($s1_dbh);
$s2_status = $self->get_slave_status($s2_dbh);
$s1_pos = $self->repl_posn($s1_status);
$s2_pos = $self->repl_posn($s2_status);
if ( $self->slave_is_running($s1_status)
|| $self->slave_is_running($s2_status)
|| $self->pos_cmp($s1_pos, $s2_pos) != 0)
{
die "The servers aren't both stopped at the same position";
}
}
sub slave_is_running {
my ( $self, $slave_status ) = @_;
return ($slave_status->{slave_sql_running} || 'No') eq 'Yes';
}
sub has_slave_updates {
my ( $self, $dbh ) = @_;
my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'};
PTDEBUG && _d($dbh, $sql);
my ($name, $value) = $dbh->selectrow_array($sql);
return $value && $value =~ m/^(1|ON)$/;
}
sub repl_posn {
my ( $self, $status ) = @_;
if ( exists $status->{file} && exists $status->{position} ) {
return {
file => $status->{file},
position => $status->{position},
};
}
else {
return {
file => $status->{relay_master_log_file},
position => $status->{exec_master_log_pos},
};
}
}
sub get_slave_lag {
my ( $self, $dbh ) = @_;
my $stat = $self->get_slave_status($dbh);
return unless $stat; # server is not a slave
return $stat->{seconds_behind_master};
}
sub pos_cmp {
my ( $self, $a, $b ) = @_;
return $self->pos_to_string($a) cmp $self->pos_to_string($b);
}
sub short_host {
my ( $self, $dsn ) = @_;
my ($host, $port);
if ( $dsn->{master_host} ) {
$host = $dsn->{master_host};
$port = $dsn->{master_port};
}
else {
$host = $dsn->{h};
$port = $dsn->{P};
}
return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" );
}
sub is_replication_thread {
my ( $self, $query, %args ) = @_;
return unless $query;
my $type = lc($args{type} || 'all');
die "Invalid type: $type"
unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i;
my $match = 0;
if ( $type =~ m/binlog_dump|all/i ) {
$match = 1
if ($query->{Command} || $query->{command} || '') eq "Binlog Dump";
}
if ( !$match ) {
if ( ($query->{User} || $query->{user} || '') eq "system user" ) {
PTDEBUG && _d("Slave replication thread");
if ( $type ne 'all' ) {
my $state = $query->{State} || $query->{state} || '';
if ( $state =~ m/^init|end$/ ) {
PTDEBUG && _d("Special state:", $state);
$match = 1;
}
else {
my ($slave_sql) = $state =~ m/
^(Waiting\sfor\sthe\snext\sevent
|Reading\sevent\sfrom\sthe\srelay\slog
|Has\sread\sall\srelay\slog;\swaiting
|Making\stemp\sfile
|Waiting\sfor\sslave\smutex\son\sexit)/xi;
$match = $type eq 'slave_sql' && $slave_sql ? 1
: $type eq 'slave_io' && !$slave_sql ? 1
: 0;
}
}
else {
$match = 1;
}
}
else {
PTDEBUG && _d('Not system user');
}
if ( !defined $args{check_known_ids} || $args{check_known_ids} ) {
my $id = $query->{Id} || $query->{id};
if ( $match ) {
$self->{replication_thread}->{$id} = 1;
}
else {
if ( $self->{replication_thread}->{$id} ) {
PTDEBUG && _d("Thread ID is a known replication thread ID");
$match = 1;
}
}
}
}
PTDEBUG && _d('Matches', $type, 'replication thread:',
($match ? 'yes' : 'no'), '; match:', $match);
return $match;
}
sub get_replication_filters {
my ( $self, %args ) = @_;
my @required_args = qw(dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh) = @args{@required_args};
my %filters = ();
my $status = $self->get_master_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
binlog_do_db
binlog_ignore_db
);
}
$status = $self->get_slave_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
replicate_do_db
replicate_ignore_db
replicate_do_table
replicate_ignore_table
replicate_wild_do_table
replicate_wild_ignore_table
);
my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'";
PTDEBUG && _d($dbh, $sql);
my $row = $dbh->selectrow_arrayref($sql);
$filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF';
}
return \%filters;
}
sub pos_to_string {
my ( $self, $pos ) = @_;
my $fmt = '%s/%020d';
return sprintf($fmt, @{$pos}{qw(file position)});
}
sub reset_known_replication_threads {
my ( $self ) = @_;
$self->{replication_thread} = {};
return;
}
sub get_cxn_from_dsn_table {
my ($self, %args) = @_;
my @required_args = qw(dsn_table_dsn make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dsn_table_dsn, $make_cxn) = @args{@required_args};
PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn);
my $dp = $self->{DSNParser};
my $q = $self->{Quoter};
my $dsn = $dp->parse($dsn_table_dsn);
my $dsn_table;
if ( $dsn->{D} && $dsn->{t} ) {
$dsn_table = $q->quote($dsn->{D}, $dsn->{t});
}
elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) {
$dsn_table = $q->quote($q->split_unquote($dsn->{t}));
}
else {
die "DSN table DSN does not specify a database (D) "
. "or a database-qualified table (t)";
}
my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn);
my $dbh = $dsn_tbl_cxn->connect();
my $sql = "SELECT dsn FROM $dsn_table ORDER BY id";
PTDEBUG && _d($sql);
my $dsn_strings = $dbh->selectcol_arrayref($sql);
my @cxn;
if ( $dsn_strings ) {
foreach my $dsn_string ( @$dsn_strings ) {
PTDEBUG && _d('DSN from DSN table:', $dsn_string);
push @cxn, $make_cxn->(dsn_string => $dsn_string);
}
}
return \@cxn;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MasterSlave package
# ###########################################################################
# ###########################################################################
# FlowControlWaiter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/FlowControlWaiter.pm
# t/lib/FlowControlWaiter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package FlowControlWaiter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::HiRes qw(sleep time);
use Data::Dumper;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(oktorun node sleep max_flow_ctl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $self = {
%args
};
$self->{last_time} = time();
my (undef, $last_fc_ns) = $self->{node}->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"');
$self->{last_fc_secs} = $last_fc_ns/1000_000_000;
return bless $self, $class;
}
sub wait {
my ( $self, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $pr = $args{Progress};
my $oktorun = $self->{oktorun};
my $sleep = $self->{sleep};
my $node = $self->{node};
my $max_avg = $self->{max_flow_ctl}/100;
my $too_much_fc = 1;
my $pr_callback;
if ( $pr ) {
$pr_callback = sub {
print STDERR "Pausing because PXC Flow Control is active\n";
return;
};
$pr->set_callback($pr_callback);
}
while ( $oktorun->() && $too_much_fc ) {
my $current_time = time();
my (undef, $current_fc_ns) = $node->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"');
my $current_fc_secs = $current_fc_ns/1000_000_000;
my $current_avg = ($current_fc_secs - $self->{last_fc_secs}) / ($current_time - $self->{last_time});
if ( $current_avg > $max_avg ) {
if ( $pr ) {
$pr->update(sub { return 0; });
}
PTDEBUG && _d('Calling sleep callback');
if ( $self->{simple_progress} ) {
print STDERR "Waiting for Flow Control to abate\n";
}
$sleep->();
} else {
$too_much_fc = 0;
}
$self->{last_time} = $current_time;
$self->{last_fc_secs} = $current_fc_secs;
}
PTDEBUG && _d('Flow Control is Ok');
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End FlowControlWaiter package
# ###########################################################################
# ###########################################################################
# Cxn package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Cxn.pm
# t/lib/Cxn.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Cxn;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Scalar::Util qw(blessed);
use constant {
PTDEBUG => $ENV{PTDEBUG} || 0,
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
};
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(DSNParser OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($dp, $o) = @args{@required_args};
my $dsn_defaults = $dp->parse_options($o);
my $prev_dsn = $args{prev_dsn};
my $dsn = $args{dsn};
if ( !$dsn ) {
$args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
$dsn = $dp->parse(
$args{dsn_string}, $prev_dsn, $dsn_defaults);
}
elsif ( $prev_dsn ) {
$dsn = $dp->copy($prev_dsn, $dsn);
}
my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
my $self = {
dsn => $dsn,
dbh => $args{dbh},
dsn_name => $dsn_name,
hostname => '',
set => $args{set},
NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
dbh_set => 0,
ask_pass => $o->get('ask-pass'),
DSNParser => $dp,
is_cluster_node => undef,
parent => $args{parent},
};
return bless $self, $class;
}
sub connect {
my ( $self, %opts ) = @_;
my $dsn = $opts{dsn} || $self->{dsn};
my $dp = $self->{DSNParser};
my $dbh = $self->{dbh};
if ( !$dbh || !$dbh->ping() ) {
if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) {
$dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
$self->{asked_for_pass} = 1;
}
$dbh = $dp->get_dbh(
$dp->get_cxn_params($dsn),
{
AutoCommit => 1,
%opts,
},
);
}
$dbh = $self->set_dbh($dbh);
if ( $opts{dsn} ) {
$self->{dsn} = $dsn;
$self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
}
PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
return $dbh;
}
sub set_dbh {
my ($self, $dbh) = @_;
if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
PTDEBUG && _d($dbh, 'Already set dbh');
return $dbh;
}
PTDEBUG && _d($dbh, 'Setting dbh');
$dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
PTDEBUG && _d($dbh, $sql);
my ($server_id, $hostname) = $dbh->selectrow_array($sql);
PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
if ( $hostname ) {
$self->{hostname} = $hostname;
}
if ( $self->{parent} ) {
PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
$dbh->{InactiveDestroy} = 1;
}
if ( my $set = $self->{set}) {
$set->($dbh);
}
$self->{dbh} = $dbh;
$self->{dbh_set} = 1;
return $dbh;
}
sub lost_connection {
my ($self, $e) = @_;
return 0 unless $e;
return $e =~ m/MySQL server has gone away/
|| $e =~ m/Lost connection to MySQL server/;
}
sub dbh {
my ($self) = @_;
return $self->{dbh};
}
sub dsn {
my ($self) = @_;
return $self->{dsn};
}
sub name {
my ($self) = @_;
return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
return $self->{hostname} || $self->{dsn_name} || 'unknown host';
}
sub get_id {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $unique_id;
if ($cxn->is_cluster_node()) { # for cluster we concatenate various variables to maximize id 'uniqueness' across versions
my $sql = q{SHOW STATUS LIKE 'wsrep\_local\_index'};
my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql);
PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index);
$unique_id = $wsrep_local_index."|";
foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
my $sql = "SHOW VARIABLES LIKE '$val'";
PTDEBUG && _d($cxn->name, $sql);
my (undef, $val) = $cxn->dbh->selectrow_array($sql);
$unique_id .= "|$val";
}
} else {
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
$unique_id = $cxn->dbh->selectrow_array($sql);
}
PTDEBUG && _d("Generated unique id for cluster:", $unique_id);
return $unique_id;
}
sub is_cluster_node {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
my $dbh;
if ($cxn->isa('DBI::db')) {
$dbh = $cxn;
PTDEBUG && _d($sql); #don't invoke name() if it's not a Cxn!
}
else {
$dbh = $cxn->dbh();
PTDEBUG && _d($cxn->name, $sql);
}
my $row = $dbh->selectrow_arrayref($sql);
return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0;
}
sub remove_duplicate_cxns {
my ($self, %args) = @_;
my @cxns = @{$args{cxns}};
my $seen_ids = $args{seen_ids} || {};
PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
my @trimmed_cxns;
for my $cxn ( @cxns ) {
my $id = $cxn->get_id();
PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
if ( ! $seen_ids->{$id}++ ) {
push @trimmed_cxns, $cxn
}
else {
PTDEBUG && _d("Removing ", $cxn->name,
", ID ", $id, ", because we've already seen it");
}
}
return \@trimmed_cxns;
}
sub DESTROY {
my ($self) = @_;
PTDEBUG && _d('Destroying cxn');
if ( $self->{parent} ) {
PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
}
elsif ( $self->{dbh}
&& blessed($self->{dbh})
&& $self->{dbh}->can("disconnect") )
{
PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
$self->{dsn_name});
$self->{dbh}->disconnect();
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Cxn package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
{
my $file = 'percona-version-check';
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => md5_hex( hostname() ),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
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}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_archiver;
use English qw(-no_match_vars);
use List::Util qw(max);
use IO::File;
use sigtrap qw(handler finish untrapped normal-signals);
use Time::HiRes qw(gettimeofday sleep time);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Quotekeys = 0;
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
# Global variables; as few as possible.
my $oktorun = 1;
my $txn_cnt = 0;
my $cnt = 0;
my $can_retry = 1;
my $archive_fh;
my $get_sth;
my ( $OUT_OF_RETRIES, $ROLLED_BACK, $ALL_IS_WELL ) = ( 0, -1, 1 );
my ( $src, $dst );
my $pxc_version = '0';
# Holds the arguments for the $sth's bind variables, so it can be re-tried
# easily.
my @beginning_of_txn;
my $q = new Quoter;
sub main {
local @ARGV = @_; # set global ARGV for this package
# Reset global vars else tests, which run this tool as a module,
# may encounter weird results.
$oktorun = 1;
$txn_cnt = 0;
$cnt = 0;
$can_retry = 1;
$archive_fh = undef;
$get_sth = undef;
($src, $dst) = (undef, undef);
@beginning_of_txn = ();
undef *trace;
($OUT_OF_RETRIES, $ROLLED_BACK, $ALL_IS_WELL ) = (0, -1, 1);
# ########################################################################
# Get configuration information.
# ########################################################################
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser();
$dp->prop('set-vars', $o->set_vars());
# Frequently used options.
$src = $o->get('source');
$dst = $o->get('dest');
my $sentinel = $o->get('sentinel');
my $bulk_del = $o->get('bulk-delete');
my $commit_each = $o->get('commit-each');
my $limit = $o->get('limit');
my $archive_file = $o->get('file');
my $txnsize = $o->get('txn-size');
my $quiet = $o->get('quiet');
my $got_charset = $o->get('charset');
# First things first: if --stop was given, create the sentinel file.
if ( $o->get('stop') ) {
my $sentinel_fh = IO::File->new($sentinel, ">>")
or die "Cannot open $sentinel: $OS_ERROR\n";
print $sentinel_fh "Remove this file to permit pt-archiver to run\n"
or die "Cannot write to $sentinel: $OS_ERROR\n";
close $sentinel_fh
or die "Cannot close $sentinel: $OS_ERROR\n";
print STDOUT "Successfully created file $sentinel\n"
unless $quiet;
return 0;
}
# Generate a filename with sprintf-like formatting codes.
if ( $archive_file ) {
my @time = localtime();
my %fmt = (
d => sprintf('%02d', $time[3]),
H => sprintf('%02d', $time[2]),
i => sprintf('%02d', $time[1]),
m => sprintf('%02d', $time[4] + 1),
s => sprintf('%02d', $time[0]),
Y => $time[5] + 1900,
D => $src && $src->{D} ? $src->{D} : '',
t => $src && $src->{t} ? $src->{t} : '',
);
$archive_file =~ s/%([dHimsYDt])/$fmt{$1}/g;
}
if ( !$o->got('help') ) {
$o->save_error("--source DSN requires a 't' (table) part")
unless $src->{t};
if ( $dst ) {
# Ensure --source and --dest don't point to the same place
my $same = 1;
foreach my $arg ( qw(h P D t S) ) {
if ( defined $src->{$arg} && defined $dst->{$arg}
&& $src->{$arg} ne $dst->{$arg} ) {
$same = 0;
last;
}
}
if ( $same ) {
$o->save_error("--source and --dest refer to the same table");
}
}
if ( $o->get('bulk-insert') ) {
$o->save_error("--bulk-insert is meaningless without a destination")
unless $dst;
$bulk_del = 1; # VERY IMPORTANT for safety.
}
if ( $bulk_del && $limit < 2 ) {
$o->save_error("--bulk-delete is meaningless with --limit 1");
}
if ( $o->got('purge') && $o->got('no-delete') ) {
$o->save_error("--purge and --no-delete are mutually exclusive");
}
}
if ( $bulk_del || $o->get('bulk-insert') ) {
$o->set('commit-each', 1);
}
$o->usage_or_errors();
# ########################################################################
# If --pid, check it first since we'll die if it already exits.
# ########################################################################
my $daemon;
if ( $o->get('pid') ) {
# We're not daemoninzing, it just handles PID stuff. Keep $daemon
# in the the scope of main() because when it's destroyed it automatically
# removes the PID file.
$daemon = new Daemon(o=>$o);
$daemon->make_PID_file();
}
# ########################################################################
# Set up statistics.
# ########################################################################
my %statistics = ();
my $stat_start;
if ( $o->get('statistics') ) {
my $start = gettimeofday();
my $obs_cost = gettimeofday() - $start; # cost of observation
*trace = sub {
my ( $thing, $sub ) = @_;
my $start = gettimeofday();
$sub->();
$statistics{$thing . '_time'}
+= (gettimeofday() - $start - $obs_cost);
++$statistics{$thing . '_count'};
$stat_start ||= $start;
}
}
else { # Generate a version that doesn't do any timing
*trace = sub {
my ( $thing, $sub ) = @_;
$sub->();
}
}
# ########################################################################
# Inspect DB servers and tables.
# ########################################################################
my $tp = new TableParser(Quoter => $q);
foreach my $table ( grep { $_ } ($src, $dst) ) {
my $ac = !$txnsize && !$commit_each;
if ( !defined $table->{p} && $o->get('ask-pass') ) {
$table->{p} = OptionParser::prompt_noecho("Enter password: ");
}
my $dbh = $dp->get_dbh(
$dp->get_cxn_params($table), { AutoCommit => $ac });
PTDEBUG && _d('Inspecting table on', $dp->as_string($table));
# Set options that can enable removing data on the master
# and archiving it on the slaves.
if ( $table->{a} ) {
$dbh->do("USE $table->{a}");
}
if ( $table->{b} ) {
$dbh->do("SET SQL_LOG_BIN=0");
}
$table->{dbh} = $dbh;
$table->{irot} = get_irot($dbh);
$can_retry = $can_retry && !$table->{irot};
$table->{db_tbl} = $q->quote(
map { $_ =~ s/(^`|`$)//g; $_; }
grep { $_ }
( $table->{D}, $table->{t} )
);
# Create objects for archivable and dependency handling, BEFORE getting
# the tbl structure (because the object might do some setup, including
# creating the table to be archived).
if ( $table->{m} ) {
eval "require $table->{m}";
die $EVAL_ERROR if $EVAL_ERROR;
trace('plugin_start', sub {
$table->{plugin} = $table->{m}->new(
dbh => $table->{dbh},
db => $table->{D},
tbl => $table->{t},
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
);
});
}
$table->{info} = $tp->parse(
$tp->get_create_table( $dbh, $table->{D}, $table->{t} ));
if ( $o->get('check-charset') ) {
my $sql = 'SELECT CONCAT(/*!40100 @@session.character_set_connection, */ "")';
PTDEBUG && _d($sql);
my ($dbh_charset) = $table->{dbh}->selectrow_array($sql);
if ( ($dbh_charset || "") ne ($table->{info}->{charset} || "") ) {
$src->{dbh}->disconnect() if $src && $src->{dbh};
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
die "Character set mismatch: "
. ($src && $table eq $src ? "--source " : "--dest ")
. "DSN uses " . ($dbh_charset || "")
. ", table uses " . ($table->{info}->{charset} || "")
. ". You can disable this check by specifying "
. "--no-check-charset.\n";
}
}
}
if ( $o->get('primary-key-only')
&& !exists $src->{info}->{keys}->{PRIMARY} ) {
$src->{dbh}->disconnect();
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
die "--primary-key-only was specified by the --source table "
. "$src->{db_tbl} does not have a PRIMARY KEY";
}
if ( $dst && $o->get('check-columns') ) {
my @not_in_src = grep {
!$src->{info}->{is_col}->{$_}
} @{$dst->{info}->{cols}};
if ( @not_in_src ) {
$src->{dbh}->disconnect();
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
die "The following columns exist in --dest but not --source: "
. join(', ', @not_in_src)
. "\n";
}
my @not_in_dst = grep {
!$dst->{info}->{is_col}->{$_}
} @{$src->{info}->{cols}};
if ( @not_in_dst ) {
$src->{dbh}->disconnect();
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
die "The following columns exist in --source but not --dest: "
. join(', ', @not_in_dst)
. "\n";
}
}
# ########################################################################
# Get lag dbh.
# ########################################################################
my @lag_dbh;
my $ms;
if ( $o->get('check-slave-lag') ) {
my $dsn_defaults = $dp->parse_options($o);
my $lag_slaves_dsn = $o->get('check-slave-lag');
$ms = new MasterSlave(
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
);
# we get each slave's connection handler (and its id, for debug and reporting)
for my $slave (@$lag_slaves_dsn) {
my $dsn = $dp->parse($slave, $dsn_defaults);
my $lag_dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit => 1 });
my $lag_id = $ms->short_host($dsn);
push @lag_dbh , {'dbh' => $lag_dbh, 'id' => $lag_id}
}
}
# #######################################################################
# Check if it's a cluster and if so get version
# Create FlowControlWaiter object if max-flow-ctl was specified and
# PXC version supports it
# #######################################################################
my $flow_ctl;
if ( $src && $src->{dbh} && Cxn::is_cluster_node($src->{dbh}) ) {
$pxc_version = VersionParser->new($src->{'dbh'});
if ( $o->got('max-flow-ctl') ) {
if ( $pxc_version < '5.6' ) {
die "Option '--max-flow-ctl' is only available for PXC version 5.6 "
. "or higher."
} else {
$flow_ctl = new FlowControlWaiter(
node => $src->{'dbh'},
max_flow_ctl => $o->get('max-flow-ctl'),
oktorun => sub { return $oktorun },
sleep => sub { sleep($o->get('check-interval')) },
simple_progress => $o->got('progress') ? 1 : 0,
);
}
}
}
if ( $src && $src->{dbh} && !Cxn::is_cluster_node($src->{dbh}) && $o->got('max-flow-ctl') ) {
die "Option '--max-flow-ctl' is for use with PXC clusters."
}
# ########################################################################
# Set up general plugin.
# ########################################################################
my $plugin;
if ( $o->get('plugin') ) {
eval "require " . $o->get('plugin');
die $EVAL_ERROR if $EVAL_ERROR;
$plugin = $o->get('plugin')->new(
src => $src,
dst => $dst,
opts => $o,
);
}
# ########################################################################
# Design SQL statements.
# ########################################################################
my $dbh = $src->{dbh};
my $nibbler = new TableNibbler(
TableParser => $tp,
Quoter => $q,
);
my ($first_sql, $next_sql, $del_sql, $ins_sql);
my ($sel_stmt, $ins_stmt, $del_stmt);
my (@asc_slice, @sel_slice, @del_slice, @bulkdel_slice, @ins_slice);
my @sel_cols = $o->get('columns') ? @{$o->get('columns')} # Explicit
: $o->get('primary-key-only') ? @{$src->{info}->{keys}->{PRIMARY}->{cols}}
: @{$src->{info}->{cols}}; # All
PTDEBUG && _d("sel cols: ", @sel_cols);
$del_stmt = $nibbler->generate_del_stmt(
tbl_struct => $src->{info},
cols => \@sel_cols,
index => $src->{i},
);
@del_slice = @{$del_stmt->{slice}};
# Generate statement for ascending index, if desired
if ( !$o->get('no-ascend') ) {
$sel_stmt = $nibbler->generate_asc_stmt(
tbl_struct => $src->{info},
cols => $del_stmt->{cols},
index => $del_stmt->{index},
asc_first => $o->get('ascend-first'),
# A plugin might prevent rows in the source from being deleted
# when doing single delete, but it cannot prevent rows from
# being deleted when doing a bulk delete.
asc_only => $o->get('no-delete') ? 1
: $src->{m} ? ($o->get('bulk-delete') ? 0 : 1)
: 0,
)
}
else {
$sel_stmt = {
cols => $del_stmt->{cols},
index => undef,
where => '1=1',
slice => [], # No-ascend = no bind variables in the WHERE clause.
scols => [], # No-ascend = no bind variables in the WHERE clause.
};
}
@asc_slice = @{$sel_stmt->{slice}};
@sel_slice = 0..$#sel_cols;
$first_sql
= 'SELECT' . ( $o->get('high-priority-select') ? ' HIGH_PRIORITY' : '' )
. ' /*!40001 SQL_NO_CACHE */ '
. join(',', map { $q->quote($_) } @{$sel_stmt->{cols}} )
. " FROM $src->{db_tbl}"
. ( $sel_stmt->{index}
? ((VersionParser->new($dbh) >= '4.0.9' ? " FORCE" : " USE")
. " INDEX(`$sel_stmt->{index}`)")
: '')
. " WHERE (".$o->get('where').")";
if ( $o->get('safe-auto-increment')
&& $sel_stmt->{index}
&& scalar(@{$src->{info}->{keys}->{$sel_stmt->{index}}->{cols}}) == 1
&& $src->{info}->{is_autoinc}->{
$src->{info}->{keys}->{$sel_stmt->{index}}->{cols}->[0]
}
) {
my $col = $q->quote($sel_stmt->{scols}->[0]);
my ($val) = $dbh->selectrow_array("SELECT MAX($col) FROM $src->{db_tbl}");
$first_sql .= " AND ($col < " . $q->quote_val($val) . ")";
}
$next_sql = $first_sql;
if ( !$o->get('no-ascend') ) {
$next_sql .= " AND $sel_stmt->{where}";
}
# Obtain index cols so we can order them when ascending
# this ensures returned sets are disjoint when ran on partitioned tables
# issue 1376561
my $index_cols;
if ( $sel_stmt->{index}
&& $src->{info}->{keys}->{$sel_stmt->{index}}->{cols}
) {
$index_cols = $src->{info}->{keys}->{$sel_stmt->{index}}->{colnames};
}
foreach my $thing ( $first_sql, $next_sql ) {
$thing .= " ORDER BY $index_cols" if $index_cols;
$thing .= " LIMIT $limit";
if ( $o->get('for-update') ) {
$thing .= ' FOR UPDATE';
}
elsif ( $o->get('share-lock') ) {
$thing .= ' LOCK IN SHARE MODE';
}
}
PTDEBUG && _d("Index for DELETE:", $del_stmt->{index});
if ( !$bulk_del ) {
# The LIMIT might be 1 here, because even though a SELECT can return
# many rows, an INSERT only does one at a time. It would not be safe to
# iterate over a SELECT that was LIMIT-ed to 500 rows, read and INSERT
# one, and then delete with a LIMIT of 500. Only one row would be written
# to the file; only one would be INSERT-ed at the destination. But
# LIMIT 1 is actually only needed when the index is not unique
# (http://code.google.com/p/maatkit/issues/detail?id=1166).
$del_sql = 'DELETE'
. ($o->get('low-priority-delete') ? ' LOW_PRIORITY' : '')
. ($o->get('quick-delete') ? ' QUICK' : '')
. " FROM $src->{db_tbl} WHERE $del_stmt->{where}";
if ( $src->{info}->{keys}->{$del_stmt->{index}}->{is_unique} ) {
PTDEBUG && _d("DELETE index is unique; LIMIT 1 is not needed");
}
else {
PTDEBUG && _d("Adding LIMIT 1 to DELETE because DELETE index "
. "is not unique");
$del_sql .= " LIMIT 1";
}
}
else {
# Unless, of course, it's a bulk DELETE, in which case the 500 rows have
# already been INSERT-ed.
my $asc_stmt = $nibbler->generate_asc_stmt(
tbl_struct => $src->{info},
cols => $del_stmt->{cols},
index => $del_stmt->{index},
asc_first => 0,
);
$del_sql = 'DELETE'
. ($o->get('low-priority-delete') ? ' LOW_PRIORITY' : '')
. ($o->get('quick-delete') ? ' QUICK' : '')
. " FROM $src->{db_tbl} WHERE ("
. $asc_stmt->{boundaries}->{'>='}
. ') AND (' . $asc_stmt->{boundaries}->{'<='}
# Unlike the row-at-a-time DELETE, this one must include the user's
# specified WHERE clause and an appropriate LIMIT clause.
. ") AND (".$o->get('where').")"
. ($o->get('bulk-delete-limit') ? " LIMIT $limit" : "");
@bulkdel_slice = @{$asc_stmt->{slice}};
}
if ( $dst ) {
$ins_stmt = $nibbler->generate_ins_stmt(
ins_tbl => $dst->{info},
sel_cols => \@sel_cols,
);
PTDEBUG && _d("inst stmt: ", Dumper($ins_stmt));
@ins_slice = @{$ins_stmt->{slice}};
if ( $o->get('bulk-insert') ) {
$ins_sql = 'LOAD DATA'
. ($o->get('low-priority-insert') ? ' LOW_PRIORITY' : '')
. ' LOCAL INFILE ?'
. ($o->get('replace') ? ' REPLACE' : '')
. ($o->get('ignore') ? ' IGNORE' : '')
. " INTO TABLE $dst->{db_tbl}"
. ($got_charset ? "CHARACTER SET $got_charset" : "")
. "("
. join(",", map { $q->quote($_) } @{$ins_stmt->{cols}} )
. ")";
}
else {
$ins_sql = ($o->get('replace') ? 'REPLACE' : 'INSERT')
. ($o->get('low-priority-insert') ? ' LOW_PRIORITY' : '')
. ($o->get('delayed-insert') ? ' DELAYED' : '')
. ($o->get('ignore') ? ' IGNORE' : '')
. " INTO $dst->{db_tbl}("
. join(",", map { $q->quote($_) } @{$ins_stmt->{cols}} )
. ") VALUES ("
. join(",", map { "?" } @{$ins_stmt->{cols}} ) . ")";
}
}
else {
$ins_sql = '';
}
if ( PTDEBUG ) {
_d("get first sql:", $first_sql);
_d("get next sql:", $next_sql);
_d("del row sql:", $del_sql);
_d("ins row sql:", $ins_sql);
}
if ( $o->get('dry-run') ) {
if ( !$quiet ) {
print join("\n", grep { $_ } ($archive_file || ''),
$first_sql, $next_sql,
($o->get('no-delete') ? '' : $del_sql), $ins_sql)
, "\n";
}
$src->{dbh}->disconnect();
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
return 0;
}
my $get_first = $dbh->prepare($first_sql);
my $get_next = $dbh->prepare($next_sql);
my $del_row = $dbh->prepare($del_sql);
my $ins_row = $dst->{dbh}->prepare($ins_sql) if $dst; # Different $dbh!
# ########################################################################
# Set MySQL options.
# ########################################################################
if ( $o->get('skip-foreign-key-checks') ) {
$src->{dbh}->do("/*!40014 SET FOREIGN_KEY_CHECKS=0 */");
if ( $dst ) {
$dst->{dbh}->do("/*!40014 SET FOREIGN_KEY_CHECKS=0 */");
}
}
# ########################################################################
# Set up the plugins
# ########################################################################
foreach my $table ( $dst, $src ) {
next unless $table && $table->{plugin};
trace ('before_begin', sub {
$table->{plugin}->before_begin(
cols => \@sel_cols,
allcols => $sel_stmt->{cols},
);
});
}
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [
{ dbh => $src->{dbh}, dsn => $src->{dsn} },
( $dst ? { dbh => $dst->{dbh}, dsn => $dst->{dsn} } : () ),
],
);
}
# ########################################################################
# Start archiving.
# ########################################################################
my $start = time();
my $end = $start + ($o->get('run-time') || 0); # When to exit
my $now = $start;
my $last_select_time; # for --sleep-coef
my $retries = $o->get('retries');
printf("%-19s %7s %7s\n", 'TIME', 'ELAPSED', 'COUNT')
if $o->get('progress') && !$quiet;
printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt)
if $o->get('progress') && !$quiet;
$get_sth = $get_first; # Later it may be assigned $get_next
trace('select', sub {
my $select_start = time;
$get_sth->execute;
$last_select_time = time - $select_start;
$statistics{SELECT} += $get_sth->rows;
});
my $row = $get_sth->fetchrow_arrayref();
PTDEBUG && _d("First row: ", Dumper($row), 'rows:', $get_sth->rows);
if ( !$row ) {
$get_sth->finish;
$src->{dbh}->disconnect();
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
return 0;
}
my $charset = $got_charset || '';
if ($charset eq 'utf8') {
$charset = ":$charset";
}
elsif ($charset) {
eval { require Encode }
or (PTDEBUG &&
_d("Couldn't load Encode: ", $EVAL_ERROR,
"Going to try using the charset ",
"passed in without checking it."));
# No need to punish a user if they did their
# homework and passed in an official charset,
# rather than an alias.
$charset = ":encoding("
. (defined &Encode::resolve_alias
? Encode::resolve_alias($charset) || $charset
: $charset)
. ")";
}
if ( $charset eq ':utf8' && $DBD::mysql::VERSION lt '4'
&& ( $archive_file || $o->get('bulk-insert') ) )
{
my $plural = '';
my $files = $archive_file ? '--file' : '';
if ( $o->get('bulk-insert') ) {
if ($files) {
$plural = 's';
$files .= $files ? ' and ' : '';
}
$files .= '--bulk-insert'
}
warn "Setting binmode :raw instead of :utf8 on $files file$plural "
. "because DBD::mysql 3.0007 has a bug with UTF-8. "
. "Verify the $files file$plural, as the bug may lead to "
. "data being double-encoded. Update DBD::mysql to avoid "
. "this warning.";
$charset = ":raw";
}
# Open the file and print the header to it.
if ( $archive_file ) {
my $need_hdr = $o->get('header') && !-f $archive_file;
$archive_fh = IO::File->new($archive_file, ">>$charset")
or die "Cannot open $charset $archive_file: $OS_ERROR\n";
$archive_fh->autoflush(1) unless $o->get('buffer');
if ( $need_hdr ) {
print { $archive_fh } '', escape(\@sel_cols), "\n"
or die "Cannot write to $archive_file: $OS_ERROR\n";
}
}
# Open the bulk insert file, which doesn't get any header info.
my $bulkins_file;
if ( $o->get('bulk-insert') ) {
require File::Temp;
$bulkins_file = File::Temp->new( SUFFIX => 'pt-archiver' )
or die "Cannot open temp file: $OS_ERROR\n";
binmode($bulkins_file, $charset)
or die "Cannot set $charset as an encoding for the bulk-insert "
. "file: $OS_ERROR";
}
# This row is the first row fetched from each 'chunk'.
my $first_row = [ @$row ];
my $csv_row;
my $flow_ctl_count = 0;
my $lag_count = 0;
my $bulk_count = 0;
ROW:
while ( # Quit if:
$row # There is no data
&& $retries >= 0 # or retries are exceeded
&& (!$o->get('run-time') || $now < $end) # or time is exceeded
&& !-f $sentinel # or the sentinel is set
&& $oktorun # or instructed to quit
)
{
my $lastrow = $row;
if ( !$src->{plugin}
|| trace('is_archivable', sub {
$src->{plugin}->is_archivable(row => $row)
})
) {
# Do the archiving. Write to the file first since, like the file,
# MyISAM and other tables cannot be rolled back etc. If there is a
# problem, hopefully the data has at least made it to the file.
my $escaped_row;
if ( $archive_fh || $bulkins_file ) {
$escaped_row = escape([@{$row}[@sel_slice]]);
}
if ( $archive_fh ) {
trace('print_file', sub {
print $archive_fh $escaped_row, "\n"
or die "Cannot write to $archive_file: $OS_ERROR\n";
});
}
# ###################################################################
# This code is for the row-at-a-time archiving functionality.
# ###################################################################
# INSERT must come first, to be as safe as possible.
if ( $dst && !$bulkins_file ) {
my $ins_sth; # Let plugin change which sth is used for the INSERT.
if ( $dst->{plugin} ) {
trace('before_insert', sub {
$dst->{plugin}->before_insert(row => $row);
});
trace('custom_sth', sub {
$ins_sth = $dst->{plugin}->custom_sth(
row => $row, sql => $ins_sql);
});
}
$ins_sth ||= $ins_row; # Default to the sth decided before.
my $success = do_with_retries($o, 'inserting', sub {
my $ins_cnt = $ins_sth->execute(@{$row}[@ins_slice]);
PTDEBUG && _d('Inserted', $ins_cnt, 'rows');
$statistics{INSERT} += $ins_sth->rows;
});
if ( $success == $OUT_OF_RETRIES ) {
$retries = -1;
last ROW;
}
elsif ( $success == $ROLLED_BACK ) {
--$retries;
next ROW;
}
}
if ( !$bulk_del ) {
# DELETE comes after INSERT for safety.
if ( $src->{plugin} ) {
trace('before_delete', sub {
$src->{plugin}->before_delete(row => $row);
});
}
if ( !$o->get('no-delete') ) {
my $success = do_with_retries($o, 'deleting', sub {
$del_row->execute(@{$row}[@del_slice]);
PTDEBUG && _d('Deleted', $del_row->rows, 'rows');
$statistics{DELETE} += $del_row->rows;
});
if ( $success == $OUT_OF_RETRIES ) {
$retries = -1;
last ROW;
}
elsif ( $success == $ROLLED_BACK ) {
--$retries;
next ROW;
}
}
}
# ###################################################################
# This code is for the bulk archiving functionality.
# ###################################################################
if ( $bulkins_file ) {
trace('print_bulkfile', sub {
print $bulkins_file $escaped_row, "\n"
or die "Cannot write to bulk file: $OS_ERROR\n";
});
}
} # row is archivable
$now = time();
++$cnt;
++$txn_cnt;
$retries = $o->get('retries');
# Possibly flush the file and commit the insert and delete.
commit($o) unless $commit_each;
# Report on progress.
if ( !$quiet && $o->get('progress') && $cnt % $o->get('progress') == 0 ) {
printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt);
}
# Get the next row in this chunk.
# First time through this loop $get_sth is set to $get_first.
# For non-bulk operations this means that rows ($row) are archived
# one-by-one in in the code block above ("row is archivable"). For
# bulk operations, the 2nd to 2nd-to-last rows are ignored and
# only the first row ($first_row) and the last row ($last_row) of
# this chunk are used to do bulk INSERT or DELETE on the range of
# rows between first and last. After the bulk ops, $first_row and
# $last_row are reset to the next chunk.
if ( $get_sth->{Active} ) { # Fetch until exhausted
$row = $get_sth->fetchrow_arrayref();
}
if ( !$row ) {
PTDEBUG && _d('No more rows in this chunk; doing bulk operations');
# ###################################################################
# This code is for the bulk archiving functionality.
# ###################################################################
if ( $bulkins_file ) {
$bulkins_file->close()
or die "Cannot close bulk insert file: $OS_ERROR\n";
my $ins_sth; # Let plugin change which sth is used for the INSERT.
if ( $dst->{plugin} ) {
trace('before_bulk_insert', sub {
$dst->{plugin}->before_bulk_insert(
first_row => $first_row,
last_row => $lastrow,
filename => $bulkins_file->filename(),
);
});
trace('custom_sth', sub {
$ins_sth = $dst->{plugin}->custom_sth_bulk(
first_row => $first_row,
last_row => $lastrow,
filename => $bulkins_file->filename(),
sql => $ins_sql,
);
});
}
$ins_sth ||= $ins_row; # Default to the sth decided before.
my $success = do_with_retries($o, 'bulk_inserting', sub {
$ins_sth->execute($bulkins_file->filename());
$src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src;
PTDEBUG && _d('Bulk inserted', $del_row->rows, 'rows');
$statistics{INSERT} += $ins_sth->rows;
});
if ( $success != $ALL_IS_WELL ) {
$retries = -1;
last ROW; # unlike other places, don't do 'next'
}
}
if ( $bulk_del ) {
if ( $src->{plugin} ) {
trace('before_bulk_delete', sub {
$src->{plugin}->before_bulk_delete(
first_row => $first_row,
last_row => $lastrow,
);
});
}
if ( !$o->get('no-delete') ) {
my $success = do_with_retries($o, 'bulk_deleting', sub {
$del_row->execute(
@{$first_row}[@bulkdel_slice],
@{$lastrow}[@bulkdel_slice],
);
PTDEBUG && _d('Bulk deleted', $del_row->rows, 'rows');
$statistics{DELETE} += $del_row->rows;
});
if ( $success != $ALL_IS_WELL ) {
$retries = -1;
last ROW; # unlike other places, don't do 'next'
}
}
}
# ###################################################################
# This code is for normal operation AND bulk operation.
# ###################################################################
commit($o, 1) if $commit_each;
$get_sth = $get_next;
# Sleep between fetching the next chunk of rows.
if( my $sleep_time = $o->get('sleep') ) {
$sleep_time = $last_select_time * $o->get('sleep-coef')
if $o->get('sleep-coef');
PTDEBUG && _d('Sleeping', $sleep_time);
trace('sleep', sub {
sleep($sleep_time);
});
}
PTDEBUG && _d('Fetching rows in next chunk');
trace('select', sub {
my $select_start = time;
$get_sth->execute(@{$lastrow}[@asc_slice]);
$last_select_time = time - $select_start;
PTDEBUG && _d('Fetched', $get_sth->rows, 'rows');
$statistics{SELECT} += $get_sth->rows;
});
# Reset $first_row to the first row of this new chunk.
@beginning_of_txn = @{$lastrow}[@asc_slice] unless $txn_cnt;
$row = $get_sth->fetchrow_arrayref();
$first_row = $row ? [ @$row ] : undef;
if ( $o->get('bulk-insert') ) {
$bulkins_file = File::Temp->new( SUFFIX => 'pt-archiver' )
or die "Cannot open temp file: $OS_ERROR\n";
binmode($bulkins_file, $charset)
or die "Cannot set $charset as an encoding for the bulk-insert "
. "file: $OS_ERROR";
}
} # no next row (do bulk operations)
else {
# keep alive every 100 rows saved to file
# https://bugs.launchpad.net/percona-toolkit/+bug/1452895
if ( $bulk_count++ % 100 == 0 ) {
$src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src;
}
PTDEBUG && _d('Got another row in this chunk');
}
# Check slave lag and wait if slave is too far behind.
# Do this check every 100 rows
if (@lag_dbh && $lag_count++ % 100 == 0 ) {
foreach my $lag_server (@lag_dbh) {
my $lag_dbh = $lag_server->{'dbh'};
my $id = $lag_server->{'id'};
if ( $lag_dbh ) {
my $lag = $ms->get_slave_lag($lag_dbh);
while ( !defined $lag || $lag > $o->get('max-lag') ) {
PTDEBUG && _d("Sleeping: slave lag for server '$id' is", $lag);
if ($o->got('progress')) {
_d("Sleeping: slave lag for server '$id' is", $lag);
}
sleep($o->get('check-interval'));
$lag = $ms->get_slave_lag($lag_dbh);
$src->{dbh}->do("SELECT 'pt-archiver keepalive'") if $src;
$dst->{dbh}->do("SELECT 'pt-archiver keepalive'") if $dst;
}
}
}
}
# if it's a cluster, check for flow control every 100 rows
if ( $flow_ctl && $flow_ctl_count++ % 100 == 0) {
$flow_ctl->wait();
}
} # ROW
PTDEBUG && _d('Done fetching rows');
# Transactions might still be open, etc
commit($o, $txnsize || $commit_each);
if ( $archive_file && $archive_fh ) {
close $archive_fh
or die "Cannot close $archive_file: $OS_ERROR\n";
}
if ( !$quiet && $o->get('progress') ) {
printf("%19s %7d %7d\n", ts($now), $now - $start, $cnt);
}
# Tear down the plugins.
foreach my $table ( $dst, $src ) {
next unless $table && $table->{plugin};
trace('after_finish', sub {
$table->{plugin}->after_finish();
});
}
# Run ANALYZE or OPTIMIZE.
if ( $oktorun && ($o->get('analyze') || $o->get('optimize')) ) {
my $action = $o->get('analyze') || $o->get('optimize');
my $maint = ($o->get('analyze') ? 'ANALYZE' : 'OPTIMIZE')
. ($o->get('local') ? ' /*!40101 NO_WRITE_TO_BINLOG*/' : '');
if ( $action =~ m/s/i ) {
trace($maint, sub {
$src->{dbh}->do("$maint TABLE $src->{db_tbl}");
});
}
if ( $action =~ m/d/i && $dst ) {
trace($maint, sub {
$dst->{dbh}->do("$maint TABLE $dst->{db_tbl}");
});
}
}
# ########################################################################
# Print statistics
# ########################################################################
if ( $plugin ) {
$plugin->statistics(\%statistics, $stat_start);
}
if ( !$quiet && $o->get('statistics') ) {
my $stat_stop = gettimeofday();
my $stat_total = $stat_stop - $stat_start;
my $total2 = 0;
my $maxlen = 0;
my %summary;
printf("Started at %s, ended at %s\n", ts($stat_start), ts($stat_stop));
print("Source: ", $dp->as_string($src), "\n");
print("Dest: ", $dp->as_string($dst), "\n") if $dst;
print(join("\n", map { "$_ " . ($statistics{$_} || 0) }
qw(SELECT INSERT DELETE)), "\n");
foreach my $thing ( grep { m/_(count|time)/ } keys %statistics ) {
my ( $action, $type ) = $thing =~ m/^(.*?)_(count|time)$/;
$summary{$action}->{$type} = $statistics{$thing};
$summary{$action}->{action} = $action;
$maxlen = max($maxlen, length($action));
# Just in case I get only one type of statistic for a given action (in
# case there was a crash or CTRL-C or something).
$summary{$action}->{time} ||= 0;
$summary{$action}->{count} ||= 0;
}
printf("%-${maxlen}s \%10s %10s %10s\n", qw(Action Count Time Pct));
my $fmt = "%-${maxlen}s \%10d %10.4f %10.2f\n";
foreach my $stat (
reverse sort { $a->{time} <=> $b->{time} } values %summary )
{
my $pct = $stat->{time} / $stat_total * 100;
printf($fmt, @{$stat}{qw(action count time)}, $pct);
$total2 += $stat->{time};
}
printf($fmt, 'other', 0, $stat_total - $total2,
($stat_total - $total2) / $stat_total * 100);
}
# Optionally print the reason for exiting. Do this even if --quiet is
# specified.
if ( $o->get('why-quit') ) {
if ( $retries < 0 ) {
print "Exiting because retries exceeded.\n";
}
elsif ( $o->get('run-time') && $now >= $end ) {
print "Exiting because time exceeded.\n";
}
elsif ( -f $sentinel ) {
print "Exiting because sentinel file $sentinel exists.\n";
}
elsif ( $o->get('statistics') ) {
print "Exiting because there are no more rows.\n";
}
}
$get_sth->finish() if $get_sth;
$src->{dbh}->disconnect();
$dst->{dbh}->disconnect() if $dst && $dst->{dbh};
return 0;
}
# ############################################################################
# Subroutines.
# ############################################################################
# Catches signals so pt-archiver can exit gracefully.
sub finish {
my ($signal) = @_;
print STDERR "Exiting on SIG$signal.\n";
$oktorun = 0;
}
# Accesses globals, but I wanted the code in one place.
sub commit {
my ( $o, $force ) = @_;
my $txnsize = $o->get('txn-size');
if ( $force || ($txnsize && $txn_cnt && $cnt % $txnsize == 0) ) {
if ( $o->get('buffer') && $archive_fh ) {
my $archive_file = $o->get('file');
trace('flush', sub {
$archive_fh->flush or die "Cannot flush $archive_file: $OS_ERROR\n";
});
}
if ( $dst ) {
trace('commit', sub {
$dst->{dbh}->commit;
});
}
trace('commit', sub {
$src->{dbh}->commit;
});
$txn_cnt = 0;
}
}
# Repeatedly retries the code until retries runs out, a really bad error
# happens, or it succeeds. This sub uses lots of global variables; I only wrote
# it to factor out some repeated code.
sub do_with_retries {
my ( $o, $doing, $code ) = @_;
my $retries = $o->get('retries');
my $txnsize = $o->get('txn-size');
my $success = $OUT_OF_RETRIES;
RETRY:
while ( !$success && $retries >= 0 ) {
eval {
trace($doing, $code);
$success = $ALL_IS_WELL;
};
if ( $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/Lock wait timeout exceeded|Deadlock found/ ) {
if (
# More than one row per txn
(
($txnsize && $txnsize > 1)
|| ($o->get('commit-each') && $o->get('limit') > 1)
)
# Not first row
&& $txn_cnt
# And it's not retry-able
&& (!$can_retry || $EVAL_ERROR =~ m/Deadlock/)
) {
# The txn, which is more than 1 statement, was rolled back.
last RETRY;
}
else {
# Only one statement had trouble, and the rest of the txn was
# not rolled back. The statement can be retried.
--$retries;
}
}
else {
die $EVAL_ERROR;
}
}
}
if ( $success != $ALL_IS_WELL ) {
# Must throw away everything and start the transaction over.
if ( $retries >= 0 ) {
warn "Deadlock or non-retryable lock wait while $doing; "
. "rolling back $txn_cnt rows.\n";
$success = $ROLLED_BACK;
}
else {
warn "Exhausted retries while $doing; rolling back $txn_cnt rows.\n";
$success = $OUT_OF_RETRIES;
}
$get_sth->finish;
trace('rollback', sub {
$dst->{dbh}->rollback;
});
trace('rollback', sub {
$src->{dbh}->rollback;
});
# I wish: $archive_fh->rollback
trace('select', sub {
$get_sth->execute(@beginning_of_txn);
});
$cnt -= $txn_cnt;
$txn_cnt = 0;
}
return $success;
}
# Formats a row the same way SELECT INTO OUTFILE does by default. This is
# described in the LOAD DATA INFILE section of the MySQL manual,
# http://dev.mysql.com/doc/refman/5.0/en/load-data.html
sub escape {
my ($row) = @_;
return join("\t", map {
s/([\t\n\\])/\\$1/g if defined $_; # Escape tabs etc
defined $_ ? $_ : '\N'; # NULL = \N
} @$row);
}
sub ts {
my ( $time ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= localtime($time);
$mon += 1;
$year += 1900;
return sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
}
sub get_irot {
my ( $dbh ) = @_;
return 1 unless VersionParser->new($dbh) >= '5.0.13';
my $rows = $dbh->selectall_arrayref(
"show variables like 'innodb_rollback_on_timeout'",
{ Slice => {} });
return 0 unless $rows;
return @$rows && $rows->[0]->{Value} ne 'OFF';
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation.
# ############################################################################
=pod
=head1 NAME
pt-archiver - Archive rows from a MySQL table into another table or a file.
=head1 SYNOPSIS
Usage: pt-archiver [OPTIONS] --source DSN --where WHERE
pt-archiver nibbles records from a MySQL table. The --source and --dest
arguments use DSN syntax; if COPY is yes, --dest defaults to the key's value
from --source.
Examples:
Archive all rows from oltp_server to olap_server and to a file:
pt-archiver --source h=oltp_server,D=test,t=tbl --dest h=olap_server \
--file '/var/log/archive/%Y-%m-%d-%D.%t' \
--where "1=1" --limit 1000 --commit-each
Purge (delete) orphan rows from child table:
pt-archiver --source h=host,D=db,t=child --purge \
--where 'NOT EXISTS(SELECT * FROM parent WHERE col=child.col)'
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-archiver is the tool I use to archive tables as described in
L. The goal is a low-impact, forward-only
job to nibble old data out of the table without impacting OLTP queries much.
You can insert the data into another table, which need not be on the same
server. You can also write it to a file in a format suitable for LOAD DATA
INFILE. Or you can do neither, in which case it's just an incremental DELETE.
pt-archiver is extensible via a plugin mechanism. You can inject your own
code to add advanced archiving logic that could be useful for archiving
dependent data, applying complex business rules, or building a data warehouse
during the archiving process.
You need to choose values carefully for some options. The most important are
L<"--limit">, L<"--retries">, and L<"--txn-size">.
The strategy is to find the first row(s), then scan some index forward-only to
find more rows efficiently. Each subsequent query should not scan the entire
table; it should seek into the index, then scan until it finds more archivable
rows. Specifying the index with the 'i' part of the L<"--source"> argument can
be crucial for this; use L<"--dry-run"> to examine the generated queries and be
sure to EXPLAIN them to see if they are efficient (most of the time you probably
want to scan the PRIMARY key, which is the default). Even better, examine the
difference in the Handler status counters before and after running the query,
and make sure it is not scanning the whole table every query.
You can disable the seek-then-scan optimizations partially or wholly with
L<"--no-ascend"> and L<"--ascend-first">. Sometimes this may be more efficient
for multi-column keys. Be aware that pt-archiver is built to start at the
beginning of the index it chooses and scan it forward-only. This might result
in long table scans if you're trying to nibble from the end of the table by an
index other than the one it prefers. See L<"--source"> and read the
documentation on the C part if this applies to you.
=head1 Percona XtraDB Cluster
pt-archiver works with Percona XtraDB Cluster (PXC) 5.5.28-23.7 and newer,
but there are three limitations you should consider before archiving on
a cluster:
=over
=item Error on commit
pt-archiver does not check for error when it commits transactions.
Commits on PXC can fail, but the tool does not yet check for or retry the
transaction when this happens. If it happens, the tool will die.
=item MyISAM tables
Archiving MyISAM tables works, but MyISAM support in PXC is still
experimental at the time of this release. There are several known bugs with
PXC, MyISAM tables, and C columns. Therefore, you must ensure
that archiving will not directly or indirectly result in the use of default
C values for a MyISAM table. For example, this happens with
L<"--dest"> if L<"--columns"> is used and the C column is not
included. The tool does not check for this!
=item Non-cluster options
Certain options may or may not work. For example, if a cluster node
is not also a slave, then L<"--check-slave-lag"> does not work. And since PXC
tables are usually InnoDB, but InnoDB doesn't support C, then
L<"--delayed-insert"> does not work. Other options may also not work, but
the tool does not check them, therefore you should test archiving on a test
cluster before archiving on your real cluster.
=back
=head1 OUTPUT
If you specify L<"--progress">, the output is a header row, plus status output
at intervals. Each row in the status output lists the current date and time,
how many seconds pt-archiver has been running, and how many rows it has
archived.
If you specify L<"--statistics">, C outputs timing and other
information to help you identify which part of your archiving process takes the
most time.
=head1 ERROR-HANDLING
pt-archiver tries to catch signals and exit gracefully; for example, if you
send it SIGTERM (Ctrl-C on UNIX-ish systems), it will catch the signal, print a
message about the signal, and exit fairly normally. It will not execute
L<"--analyze"> or L<"--optimize">, because these may take a long time to finish.
It will run all other code normally, including calling after_finish() on any
plugins (see L<"EXTENDING">).
In other words, a signal, if caught, will break out of the main archiving
loop and skip optimize/analyze.
=head1 OPTIONS
Specify at least one of L<"--dest">, L<"--file">, or L<"--purge">.
L<"--ignore"> and L<"--replace"> are mutually exclusive.
L<"--txn-size"> and L<"--commit-each"> are mutually exclusive.
L<"--low-priority-insert"> and L<"--delayed-insert"> are mutually exclusive.
L<"--share-lock"> and L<"--for-update"> are mutually exclusive.
L<"--analyze"> and L<"--optimize"> are mutually exclusive.
L<"--no-ascend"> and L<"--no-delete"> are mutually exclusive.
DSN values in L<"--dest"> default to values from L<"--source"> if COPY is yes.
=over
=item --analyze
type: string
Run ANALYZE TABLE afterwards on L<"--source"> and/or L<"--dest">.
Runs ANALYZE TABLE after finishing. The argument is an arbitrary string. If it
contains the letter 's', the source will be analyzed. If it contains 'd', the
destination will be analyzed. You can specify either or both. For example, the
following will analyze both:
--analyze=ds
See L for details on ANALYZE
TABLE.
=item --ascend-first
Ascend only first column of index.
If you do want to use the ascending index optimization (see L<"--no-ascend">),
but do not want to incur the overhead of ascending a large multi-column index,
you can use this option to tell pt-archiver to ascend only the leftmost column
of the index. This can provide a significant performance boost over not
ascending the index at all, while avoiding the cost of ascending the whole
index.
See L<"EXTENDING"> for a discussion of how this interacts with plugins.
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --buffer
Buffer output to L<"--file"> and flush at commit.
Disables autoflushing to L<"--file"> and flushes L<"--file"> to disk only when a
transaction commits. This typically means the file is block-flushed by the
operating system, so there may be some implicit flushes to disk between
commits as well. The default is to flush L<"--file"> to disk after every row.
The danger is that a crash might cause lost data.
The performance increase I have seen from using L<"--buffer"> is around 5 to 15
percent. Your mileage may vary.
=item --bulk-delete
Delete each chunk with a single statement (implies L<"--commit-each">).
Delete each chunk of rows in bulk with a single C statement. The
statement deletes every row between the first and last row of the chunk,
inclusive. It implies L<"--commit-each">, since it would be a bad idea to
C rows one at a time and commit them before the bulk C.
The normal method is to delete every row by its primary key. Bulk deletes might
be a lot faster. B if you have a complex
C clause.
This option completely defers all C processing until the chunk of rows
is finished. If you have a plugin on the source, its C method
will not be called. Instead, its C method is called later.
B: if you have a plugin on the source that sometimes doesn't return
true from C, you should use this option only if you understand
what it does. If the plugin instructs C not to archive a row,
it will still be deleted by the bulk delete!
=item --[no]bulk-delete-limit
default: yes
Add L<"--limit"> to L<"--bulk-delete"> statement.
This is an advanced option and you should not disable it unless you know what
you are doing and why! By default, L<"--bulk-delete"> appends a L<"--limit">
clause to the bulk delete SQL statement. In certain cases, this clause can be
omitted by specifying C<--no-bulk-delete-limit>. L<"--limit"> must still be
specified.
=item --bulk-insert
Insert each chunk with LOAD DATA INFILE (implies L<"--bulk-delete"> L<"--commit-each">).
Insert each chunk of rows with C. This may be much
faster than inserting a row at a time with C statements. It is
implemented by creating a temporary file for each chunk of rows, and writing the
rows to this file instead of inserting them. When the chunk is finished, it
uploads the rows.
To protect the safety of your data, this option forces bulk deletes to be used.
It would be unsafe to delete each row as it is found, before inserting the rows
into the destination first. Forcing bulk deletes guarantees that the deletion
waits until the insertion is successful.
The L<"--low-priority-insert">, L<"--replace">, and L<"--ignore"> options work
with this option, but L<"--delayed-insert"> does not.
If C throws an error in the lines of C, refer to the documentation
for the C DSN option.
=item --charset
short form: -A; type: string
Default character set. If the value is utf8, sets Perl's binmode on
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and runs SET
NAMES UTF8 after connecting to MySQL. Any other value sets binmode on STDOUT
without the utf8 layer, and runs SET NAMES after connecting to MySQL.
Note that only charsets as known by MySQL are recognized; So for example,
"UTF8" will work, but "UTF-8" will not.
See also L<"--[no]check-charset">.
=item --[no]check-charset
default: yes
Ensure connection and table character sets are the same. Disabling this check
may cause text to be erroneously converted from one character set to another
(usually from utf8 to latin1) which may cause data loss or mojibake. Disabling
this check may be useful or necessary when character set conversions are
intended.
=item --[no]check-columns
default: yes
Ensure L<"--source"> and L<"--dest"> have same columns.
Enabled by default; causes pt-archiver to check that the source and destination
tables have the same columns. It does not check column order, data type, etc.
It just checks that all columns in the source exist in the destination and
vice versa. If there are any differences, pt-archiver will exit with an
error.
To disable this check, specify --no-check-columns.
=item --check-interval
type: time; default: 1s
If L<"--check-slave-lag"> is given, this defines how long the tool pauses each
time it discovers that a slave is lagging.
This check is performed every 100 rows.
=item --check-slave-lag
type: string; repeatable: yes
Pause archiving until the specified DSN's slave lag is less than L<"--max-lag">.
This option can be specified multiple times for checking more than one slave.
=item --columns
short form: -c; type: array
Comma-separated list of columns to archive.
Specify a comma-separated list of columns to fetch, write to the file, and
insert into the destination table. If specified, pt-archiver ignores other
columns unless it needs to add them to the C statement for ascending an
index or deleting rows. It fetches and uses these extra columns internally, but
does not write them to the file or to the destination table. It I pass
them to plugins.
See also L<"--primary-key-only">.
=item --commit-each
Commit each set of fetched and archived rows (disables L<"--txn-size">).
Commits transactions and flushes L<"--file"> after each set of rows has been
archived, before fetching the next set of rows, and before sleeping if
L<"--sleep"> is specified. Disables L<"--txn-size">; use L<"--limit"> to
control the transaction size with L<"--commit-each">.
This option is useful as a shortcut to make L<"--limit"> and L<"--txn-size"> the
same value, but more importantly it avoids transactions being held open while
searching for more rows. For example, imagine you are archiving old rows from
the beginning of a very large table, with L<"--limit"> 1000 and L<"--txn-size">
1000. After some period of finding and archiving 1000 rows at a time,
pt-archiver finds the last 999 rows and archives them, then executes the next
SELECT to find more rows. This scans the rest of the table, but never finds any
more rows. It has held open a transaction for a very long time, only to
determine it is finished anyway. You can use L<"--commit-each"> to avoid this.
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line.
=item --database
short form: -D; type: string
Connect to this database.
=item --delayed-insert
Add the DELAYED modifier to INSERT statements.
Adds the DELAYED modifier to INSERT or REPLACE statements. See
L for details.
=item --dest
type: DSN
DSN specifying the table to archive to.
This item specifies a table into which pt-archiver will insert rows
archived from L<"--source">. It uses the same key=val argument format as
L<"--source">. Most missing values default to the same values as
L<"--source">, so you don't have to repeat options that are the same in
L<"--source"> and L<"--dest">. Use the L<"--help"> option to see which values
are copied from L<"--source">.
B: Using a default options file (F) DSN option that defines a
socket for L<"--source"> causes pt-archiver to connect to L<"--dest"> using
that socket unless another socket for L<"--dest"> is specified. This
means that pt-archiver may incorrectly connect to L<"--source"> when it
connects to L<"--dest">. For example:
--source F=host1.cnf,D=db,t=tbl --dest h=host2
When pt-archiver connects to L<"--dest">, host2, it will connect via the
L<"--source">, host1, socket defined in host1.cnf.
=item --dry-run
Print queries and exit without doing anything.
Causes pt-archiver to exit after printing the filename and SQL statements
it will use.
=item --file
type: string
File to archive to, with DATE_FORMAT()-like formatting.
Filename to write archived rows to. A subset of MySQL's DATE_FORMAT()
formatting codes are allowed in the filename, as follows:
%d Day of the month, numeric (01..31)
%H Hour (00..23)
%i Minutes, numeric (00..59)
%m Month, numeric (01..12)
%s Seconds (00..59)
%Y Year, numeric, four digits
You can use the following extra format codes too:
%D Database name
%t Table name
Example:
--file '/var/log/archive/%Y-%m-%d-%D.%t'
The file's contents are in the same format used by SELECT INTO OUTFILE, as
documented in the MySQL manual: rows terminated by newlines, columns
terminated by tabs, NULL characters are represented by \N, and special
characters are escaped by \. This lets you reload a file with LOAD DATA
INFILE's default settings.
If you want a column header at the top of the file, see L<"--header">. The file
is auto-flushed by default; see L<"--buffer">.
=item --for-update
Adds the FOR UPDATE modifier to SELECT statements.
For details, see L.
=item --header
Print column header at top of L<"--file">.
Writes column names as the first line in the file given by L<"--file">. If the
file exists, does not write headers; this keeps the file loadable with LOAD
DATA INFILE in case you append more output to it.
=item --help
Show help and exit.
=item --high-priority-select
Adds the HIGH_PRIORITY modifier to SELECT statements.
See L for details.
=item --host
short form: -h; type: string
Connect to host.
=item --ignore
Use IGNORE for INSERT statements.
Causes INSERTs into L<"--dest"> to be INSERT IGNORE.
=item --limit
type: int; default: 1
Number of rows to fetch and archive per statement.
Limits the number of rows returned by the SELECT statements that retrieve rows
to archive. Default is one row. It may be more efficient to increase the
limit, but be careful if you are archiving sparsely, skipping over many rows;
this can potentially cause more contention with other queries, depending on the
storage engine, transaction isolation level, and options such as
L<"--for-update">.
=item --local
Do not write OPTIMIZE or ANALYZE queries to binlog.
Adds the NO_WRITE_TO_BINLOG modifier to ANALYZE and OPTIMIZE queries. See
L<"--analyze"> for details.
=item --low-priority-delete
Adds the LOW_PRIORITY modifier to DELETE statements.
See L for details.
=item --low-priority-insert
Adds the LOW_PRIORITY modifier to INSERT or REPLACE statements.
See L for details.
=item --max-flow-ctl
type: float
Somewhat similar to --max-lag but for PXC clusters.
Check average time cluster spent pausing for Flow Control and make tool pause if
it goes over the percentage indicated in the option.
Default is no Flow Control checking.
This option is available for PXC versions 5.6 or higher.
=item --max-lag
type: time; default: 1s
Pause archiving if the slave given by L<"--check-slave-lag"> lags.
This option causes pt-archiver to look at the slave every time it's about
to fetch another row. If the slave's lag is greater than the option's value,
or if the slave isn't running (so its lag is NULL), pt-table-checksum sleeps
for L<"--check-interval"> seconds and then looks at the lag again. It repeats
until the slave is caught up, then proceeds to fetch and archive the row.
This option may eliminate the need for L<"--sleep"> or L<"--sleep-coef">.
=item --no-ascend
Do not use ascending index optimization.
The default ascending-index optimization causes C to optimize
repeated C queries so they seek into the index where the previous query
ended, then scan along it, rather than scanning from the beginning of the table
every time. This is enabled by default because it is generally a good strategy
for repeated accesses.
Large, multiple-column indexes may cause the WHERE clause to be complex enough
that this could actually be less efficient. Consider for example a four-column
PRIMARY KEY on (a, b, c, d). The WHERE clause to start where the last query
ended is as follows:
WHERE (a > ?)
OR (a = ? AND b > ?)
OR (a = ? AND b = ? AND c > ?)
OR (a = ? AND b = ? AND c = ? AND d >= ?)
Populating the placeholders with values uses memory and CPU, adds network
traffic and parsing overhead, and may make the query harder for MySQL to
optimize. A four-column key isn't a big deal, but a ten-column key in which
every column allows C might be.
Ascending the index might not be necessary if you know you are simply removing
rows from the beginning of the table in chunks, but not leaving any holes, so
starting at the beginning of the table is actually the most efficient thing to
do.
See also L<"--ascend-first">. See L<"EXTENDING"> for a discussion of how this
interacts with plugins.
=item --no-delete
Do not delete archived rows.
Causes C not to delete rows after processing them. This disallows
L<"--no-ascend">, because enabling them both would cause an infinite loop.
If there is a plugin on the source DSN, its C method is called
anyway, even though C will not execute the delete. See
L<"EXTENDING"> for more on plugins.
=item --optimize
type: string
Run OPTIMIZE TABLE afterwards on L<"--source"> and/or L<"--dest">.
Runs OPTIMIZE TABLE after finishing. See L<"--analyze"> for the option syntax
and L for details on OPTIMIZE
TABLE.
=item --password
short form: -p; type: string
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item --pid
type: string
Create the given PID file. The tool won't start if the PID file already
exists and the PID it contains is different than the current PID. However,
if the PID file exists and the PID it contains is no longer running, the
tool will overwrite the PID file with the current PID. The PID file is
removed automatically when the tool exits.
=item --plugin
type: string
Perl module name to use as a generic plugin.
Specify the Perl module name of a general-purpose plugin. It is currently used
only for statistics (see L<"--statistics">) and must have C and a
C method.
The C $src, dst => $dst, opts => $o )> method gets the source
and destination DSNs, and their database connections, just like the
connection-specific plugins do. It also gets an OptionParser object (C<$o>) for
accessing command-line options (example: C<$o->get('purge');>).
The C method gets a hashref of the statistics
collected by the archiving job, and the time the whole job started.
=item --port
short form: -P; type: int
Port number to use for connection.
=item --primary-key-only
Primary key columns only.
A shortcut for specifying L<"--columns"> with the primary key columns. This is
an efficiency if you just want to purge rows; it avoids fetching the entire row,
when only the primary key columns are needed for C statements. See also
L<"--purge">.
=item --progress
type: int
Print progress information every X rows.
Prints current time, elapsed time, and rows archived every X rows.
=item --purge
Purge instead of archiving; allows omitting L<"--file"> and L<"--dest">.
Allows archiving without a L<"--file"> or L<"--dest"> argument, which is
effectively a purge since the rows are just deleted.
If you just want to purge rows, consider specifying the table's primary key
columns with L<"--primary-key-only">. This will prevent fetching all columns
from the server for no reason.
=item --quick-delete
Adds the QUICK modifier to DELETE statements.
See L for details. As stated in the
documentation, in some cases it may be faster to use DELETE QUICK followed by
OPTIMIZE TABLE. You can use L<"--optimize"> for this.
=item --quiet
short form: -q
Do not print any output, such as for L<"--statistics">.
Suppresses normal output, including the output of L<"--statistics">, but doesn't
suppress the output from L<"--why-quit">.
=item --replace
Causes INSERTs into L<"--dest"> to be written as REPLACE.
=item --retries
type: int; default: 1
Number of retries per timeout or deadlock.
Specifies the number of times pt-archiver should retry when there is an
InnoDB lock wait timeout or deadlock. When retries are exhausted,
pt-archiver will exit with an error.
Consider carefully what you want to happen when you are archiving between a
mixture of transactional and non-transactional storage engines. The INSERT to
L<"--dest"> and DELETE from L<"--source"> are on separate connections, so they
do not actually participate in the same transaction even if they're on the same
server. However, pt-archiver implements simple distributed transactions in
code, so commits and rollbacks should happen as desired across the two
connections.
At this time I have not written any code to handle errors with transactional
storage engines other than InnoDB. Request that feature if you need it.
=item --run-time
type: time
Time to run before exiting.
Optional suffix s=seconds, m=minutes, h=hours, d=days; if no suffix, s is used.
=item --[no]safe-auto-increment
default: yes
Do not archive row with max AUTO_INCREMENT.
Adds an extra WHERE clause to prevent pt-archiver from removing the newest
row when ascending a single-column AUTO_INCREMENT key. This guards against
re-using AUTO_INCREMENT values if the server restarts, and is enabled by
default.
The extra WHERE clause contains the maximum value of the auto-increment column
as of the beginning of the archive or purge job. If new rows are inserted while
pt-archiver is running, it will not see them.
=item --sentinel
type: string; default: /tmp/pt-archiver-sentinel
Exit if this file exists.
The presence of the file specified by L<"--sentinel"> will cause pt-archiver to
stop archiving and exit. The default is /tmp/pt-archiver-sentinel. You
might find this handy to stop cron jobs gracefully if necessary. See also
L<"--stop">.
=item --set-vars
type: Array
Set the MySQL variables in this comma-separated list of C pairs.
By default, the tool sets:
=for comment ignore-pt-internal-value
MAGIC_set_vars
wait_timeout=10000
Variables specified on the command line override these defaults. For
example, specifying C<--set-vars wait_timeout=500> overrides the default
value of C<10000>.
The tool prints a warning and continues if a variable cannot be set.
=item --share-lock
Adds the LOCK IN SHARE MODE modifier to SELECT statements.
See L.
=item --skip-foreign-key-checks
Disables foreign key checks with SET FOREIGN_KEY_CHECKS=0.
=item --sleep
type: int
Sleep time between fetches.
Specifies how long to sleep between SELECT statements. Default is not to
sleep at all. Transactions are NOT committed, and the L<"--file"> file is NOT
flushed, before sleeping. See L<"--txn-size"> to control that.
If L<"--commit-each"> is specified, committing and flushing happens before
sleeping.
=item --sleep-coef
type: float
Calculate L<"--sleep"> as a multiple of the last SELECT time.
If this option is specified, pt-archiver will sleep for the query time of the
last SELECT multiplied by the specified coefficient.
This is a slightly more sophisticated way to throttle the SELECTs: sleep a
varying amount of time between each SELECT, depending on how long the SELECTs
are taking.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --source
type: DSN
DSN specifying the table to archive from (required). This argument is a DSN.
See L for the syntax. Most options control how pt-archiver
connects to MySQL, but there are some extended DSN options in this tool's
syntax. The D, t, and i options select a table to archive:
--source h=my_server,D=my_database,t=my_tbl
The a option specifies the database to set as the connection's default with USE.
If the b option is true, it disables binary logging with SQL_LOG_BIN. The m
option specifies pluggable actions, which an external Perl module can provide.
The only required part is the table; other parts may be read from various
places in the environment (such as options files).
The 'i' part deserves special mention. This tells pt-archiver which index
it should scan to archive. This appears in a FORCE INDEX or USE INDEX hint in
the SELECT statements used to fetch archivable rows. If you don't specify
anything, pt-archiver will auto-discover a good index, preferring a C if one exists. In my experience this usually works well, so most of the
time you can probably just omit the 'i' part.
The index is used to optimize repeated accesses to the table; pt-archiver
remembers the last row it retrieves from each SELECT statement, and uses it to
construct a WHERE clause, using the columns in the specified index, that should
allow MySQL to start the next SELECT where the last one ended, rather than
potentially scanning from the beginning of the table with each successive
SELECT. If you are using external plugins, please see L<"EXTENDING"> for a
discussion of how they interact with ascending indexes.
The 'a' and 'b' options allow you to control how statements flow through the
binary log. If you specify the 'b' option, binary logging will be disabled on
the specified connection. If you specify the 'a' option, the connection will
C the specified database, which you can use to prevent slaves from
executing the binary log events with C<--replicate-ignore-db> options. These
two options can be used as different methods to achieve the same goal: archive
data off the master, but leave it on the slave. For example, you can run a
purge job on the master and prevent it from happening on the slave using your
method of choice.
B: Using a default options file (F) DSN option that defines a
socket for L<"--source"> causes pt-archiver to connect to L<"--dest"> using
that socket unless another socket for L<"--dest"> is specified. This
means that pt-archiver may incorrectly connect to L<"--source"> when it
is meant to connect to L<"--dest">. For example:
--source F=host1.cnf,D=db,t=tbl --dest h=host2
When pt-archiver connects to L<"--dest">, host2, it will connect via the
L<"--source">, host1, socket defined in host1.cnf.
=item --statistics
Collect and print timing statistics.
Causes pt-archiver to collect timing statistics about what it does. These
statistics are available to the plugin specified by L<"--plugin">
Unless you specify L<"--quiet">, C prints the statistics when it
exits. The statistics look like this:
Started at 2008-07-18T07:18:53, ended at 2008-07-18T07:18:53
Source: D=db,t=table
SELECT 4
INSERT 4
DELETE 4
Action Count Time Pct
commit 10 0.1079 88.27
select 5 0.0047 3.87
deleting 4 0.0028 2.29
inserting 4 0.0028 2.28
other 0 0.0040 3.29
The first two (or three) lines show times and the source and destination tables.
The next three lines show how many rows were fetched, inserted, and deleted.
The remaining lines show counts and timing. The columns are the action, the
total number of times that action was timed, the total time it took, and the
percent of the program's total runtime. The rows are sorted in order of
descending total time. The last row is the rest of the time not explicitly
attributed to anything. Actions will vary depending on command-line options.
If L<"--why-quit"> is given, its behavior is changed slightly. This option
causes it to print the reason for exiting even when it's just because there are
no more rows.
This option requires the standard Time::HiRes module, which is part of core Perl
on reasonably new Perl releases.
=item --stop
Stop running instances by creating the sentinel file.
Causes pt-archiver to create the sentinel file specified by L<"--sentinel"> and
exit. This should have the effect of stopping all running instances which are
watching the same sentinel file.
=item --txn-size
type: int; default: 1
Number of rows per transaction.
Specifies the size, in number of rows, of each transaction. Zero disables
transactions altogether. After pt-archiver processes this many rows, it
commits both the L<"--source"> and the L<"--dest"> if given, and flushes the
file given by L<"--file">.
This parameter is critical to performance. If you are archiving from a live
server, which for example is doing heavy OLTP work, you need to choose a good
balance between transaction size and commit overhead. Larger transactions
create the possibility of more lock contention and deadlocks, but smaller
transactions cause more frequent commit overhead, which can be significant. To
give an idea, on a small test set I worked with while writing pt-archiver, a
value of 500 caused archiving to take about 2 seconds per 1000 rows on an
otherwise quiet MySQL instance on my desktop machine, archiving to disk and to
another table. Disabling transactions with a value of zero, which turns on
autocommit, dropped performance to 38 seconds per thousand rows.
If you are not archiving from or to a transactional storage engine, you may
want to disable transactions so pt-archiver doesn't try to commit.
=item --user
short form: -u; type: string
User for login if not current user.
=item --version
Show version and exit.
=item --[no]version-check
default: yes
Check for the latest version of Percona Toolkit, MySQL, and other programs.
This is a standard "check for updates automatically" feature, with two
additional features. First, the tool checks the version of other programs
on the local system in addition to its own version. For example, it checks
the version of every MySQL server it connects to, Perl, and the Perl module
DBD::mysql. Second, it checks for and warns about versions with known
problems. For example, MySQL 5.5.25 had a critical bug and was re-released
as 5.5.25a.
Any updates or known problems are printed to STDOUT before the tool's normal
output. This feature should never interfere with the normal operation of the
tool.
For more information, visit L.
=item --where
type: string
WHERE clause to limit which rows to archive (required).
Specifies a WHERE clause to limit which rows are archived. Do not include the
word WHERE. You may need to quote the argument to prevent your shell from
interpreting it. For example:
--where 'ts < current_date - interval 90 day'
For safety, L<"--where"> is required. If you do not require a WHERE clause, use
L<"--where"> 1=1.
=item --why-quit
Print reason for exiting unless rows exhausted.
Causes pt-archiver to print a message if it exits for any reason other than
running out of rows to archive. This can be useful if you have a cron job with
L<"--run-time"> specified, for example, and you want to be sure pt-archiver is
finishing before running out of time.
If L<"--statistics"> is given, the behavior is changed slightly. It will print
the reason for exiting even when it's just because there are no more rows.
This output prints even if L<"--quiet"> is given. That's so you can put
C in a C job and get an email if there's an abnormal exit.
=back
=head1 DSN OPTIONS
These DSN options are used to create a DSN. Each option is given like
C. The options are case-sensitive, so P and p are not the
same option. There cannot be whitespace before or after the C<=> and
if the value contains whitespace it must be quoted. DSN options are
comma-separated. See the L manpage for full details.
=over
=item * a
copy: no
Database to USE when executing queries.
=item * A
dsn: charset; copy: yes
Default character set.
=item * b
copy: no
If true, disable binlog with SQL_LOG_BIN.
=item * D
dsn: database; copy: yes
Database that contains the table.
=item * F
dsn: mysql_read_default_file; copy: yes
Only read default options from the given file
=item * h
dsn: host; copy: yes
Connect to host.
=item * i
copy: yes
Index to use.
=item * L
copy: yes
Explicitly enable LOAD DATA LOCAL INFILE.
For some reason, some vendors compile libmysql without the
--enable-local-infile option, which disables the statement. This can
lead to weird situations, like the server allowing LOCAL INFILE, but
the client throwing exceptions if it's used.
However, as long as the server allows LOAD DATA, clients can easily
reenable it; See L
and L.
This option does exactly that.
Although we've not found a case where turning this option leads to errors or
differing behavior, to be on the safe side, this option is not
on by default.
=item * m
copy: no
Plugin module name.
=item * p
dsn: password; copy: yes
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item * P
dsn: port; copy: yes
Port number to use for connection.
=item * S
dsn: mysql_socket; copy: yes
Socket file to use for connection.
=item * t
copy: yes
Table to archive from/to.
=item * u
dsn: user; copy: yes
User for login if not current user.
=back
=head1 EXTENDING
pt-archiver is extensible by plugging in external Perl modules to handle some
logic and/or actions. You can specify a module for both the L<"--source"> and
the L<"--dest">, with the 'm' part of the specification. For example:
--source D=test,t=test1,m=My::Module1 --dest m=My::Module2,t=test2
This will cause pt-archiver to load the My::Module1 and My::Module2 packages,
create instances of them, and then make calls to them during the archiving
process.
You can also specify a plugin with L<"--plugin">.
The module must provide this interface:
=over
=item new(dbh => $dbh, db => $db_name, tbl => $tbl_name)
The plugin's constructor is passed a reference to the database handle, the
database name, and table name. The plugin is created just after pt-archiver
opens the connection, and before it examines the table given in the arguments.
This gives the plugin a chance to create and populate temporary tables, or do
other setup work.
=item before_begin(cols => \@cols, allcols => \@allcols)
This method is called just before pt-archiver begins iterating through rows
and archiving them, but after it does all other setup work (examining table
structures, designing SQL queries, and so on). This is the only time
pt-archiver tells the plugin column names for the rows it will pass the
plugin while archiving.
The C argument is the column names the user requested to be archived,
either by default or by the L<"--columns"> option. The C argument is
the list of column names for every row pt-archiver will fetch from the source
table. It may fetch more columns than the user requested, because it needs some
columns for its own use. When subsequent plugin functions receive a row, it is
the full row containing all the extra columns, if any, added to the end.
=item is_archivable(row => \@row)
This method is called for each row to determine whether it is archivable. This
applies only to L<"--source">. The argument is the row itself, as an arrayref.
If the method returns true, the row will be archived; otherwise it will be
skipped.
Skipping a row adds complications for non-unique indexes. Normally
pt-archiver uses a WHERE clause designed to target the last processed row as
the place to start the scan for the next SELECT statement. If you have skipped
the row by returning false from is_archivable(), pt-archiver could get into
an infinite loop because the row still exists. Therefore, when you specify a
plugin for the L<"--source"> argument, pt-archiver will change its WHERE clause
slightly. Instead of starting at "greater than or equal to" the last processed
row, it will start "strictly greater than." This will work fine on unique
indexes such as primary keys, but it may skip rows (leave holes) on non-unique
indexes or when ascending only the first column of an index.
C will change the clause in the same way if you specify
L<"--no-delete">, because again an infinite loop is possible.
If you specify the L<"--bulk-delete"> option and return false from this method,
C may not do what you want. The row won't be archived, but it will
be deleted, since bulk deletes operate on ranges of rows and don't know which
rows the plugin selected to keep.
If you specify the L<"--bulk-insert"> option, this method's return value will
influence whether the row is written to the temporary file for the bulk insert,
so bulk inserts will work as expected. However, bulk inserts require bulk
deletes.
=item before_delete(row => \@row)
This method is called for each row just before it is deleted. This applies only
to L<"--source">. This is a good place for you to handle dependencies, such as
deleting things that are foreign-keyed to the row you are about to delete. You
could also use this to recursively archive all dependent tables.
This plugin method is called even if L<"--no-delete"> is given, but not if
L<"--bulk-delete"> is given.
=item before_bulk_delete(first_row => \@row, last_row => \@row)
This method is called just before a bulk delete is executed. It is similar to
the C method, except its arguments are the first and last row of
the range to be deleted. It is called even if L<"--no-delete"> is given.
=item before_insert(row => \@row)
This method is called for each row just before it is inserted. This applies
only to L<"--dest">. You could use this to insert the row into multiple tables,
perhaps with an ON DUPLICATE KEY UPDATE clause to build summary tables in a data
warehouse.
This method is not called if L<"--bulk-insert"> is given.
=item before_bulk_insert(first_row => \@row, last_row => \@row, filename => bulk_insert_filename)
This method is called just before a bulk insert is executed. It is similar to
the C method, except its arguments are the first and last row of
the range to be deleted.
=item custom_sth(row => \@row, sql => $sql)
This method is called just before inserting the row, but after
L<"before_insert()">. It allows the plugin to specify different C
statement if desired. The return value (if any) should be a DBI statement
handle. The C parameter is the SQL text used to prepare the default
C statement. This method is not called if you specify
L<"--bulk-insert">.
If no value is returned, the default C statement handle is used.
This method applies only to the plugin specified for L<"--dest">, so if your
plugin isn't doing what you expect, check that you've specified it for the
destination and not the source.
=item custom_sth_bulk(first_row => \@row, last_row => \@row, sql => $sql, filename => $bulk_insert_filename)
If you've specified L<"--bulk-insert">, this method is called just before the
bulk insert, but after L<"before_bulk_insert()">, and the arguments are
different.
This method's return value etc is similar to the L<"custom_sth()"> method.
=item after_finish()
This method is called after pt-archiver exits the archiving loop, commits all
database handles, closes L<"--file">, and prints the final statistics, but
before pt-archiver runs ANALYZE or OPTIMIZE (see L<"--analyze"> and
L<"--optimize">).
=back
If you specify a plugin for both L<"--source"> and L<"--dest">, pt-archiver
constructs, calls before_begin(), and calls after_finish() on the two plugins in
the order L<"--source">, L<"--dest">.
pt-archiver assumes it controls transactions, and that the plugin will NOT
commit or roll back the database handle. The database handle passed to the
plugin's constructor is the same handle pt-archiver uses itself. Remember
that L<"--source"> and L<"--dest"> are separate handles.
A sample module might look like this:
package My::Module;
sub new {
my ( $class, %args ) = @_;
return bless(\%args, $class);
}
sub before_begin {
my ( $self, %args ) = @_;
# Save column names for later
$self->{cols} = $args{cols};
}
sub is_archivable {
my ( $self, %args ) = @_;
# Do some advanced logic with $args{row}
return 1;
}
sub before_delete {} # Take no action
sub before_insert {} # Take no action
sub custom_sth {} # Take no action
sub after_finish {} # Take no action
1;
=head1 ENVIRONMENT
The environment variable C enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-archiver ... > FILE 2>&1
Be careful: debugging output is voluminous and can generate several megabytes
of output.
=head1 SYSTEM REQUIREMENTS
You need Perl, DBI, DBD::mysql, and some core packages that ought to be
installed in any reasonably new version of Perl.
=head1 BUGS
For a list of known bugs, see L.
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L with the name of any tool.
=head1 AUTHORS
Baron Schwartz
=head1 ACKNOWLEDGMENTS
Andrew O'Brien
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L
. qq
. (defined $val ? Lmo::Dumper($val) : 'undef') )
}
sub _nested_constraints {
my ($attribute, $aggregate_type, $type) = @_;
my $inner_types;
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$inner_types = _nested_constraints($1, $2);
}
else {
$inner_types = $TYPES{$type};
}
if ( $aggregate_type eq 'ArrayRef' ) {
return sub {
my ($val) = @_;
return unless ref($val) eq ref([]);
if ($inner_types) {
for my $value ( @{$val} ) {
return unless $inner_types->($value)
}
}
else {
for my $value ( @{$val} ) {
return unless $value && ($value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type)));
}
}
return 1;
};
}
elsif ( $aggregate_type eq 'Maybe' ) {
return sub {
my ($value) = @_;
return 1 if ! defined($value);
if ($inner_types) {
return unless $inner_types->($value)
}
else {
return unless $value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type));
}
return 1;
}
}
else {
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
}
}
1;
}
# ###########################################################################
# End Lmo::Types package
# ###########################################################################
# ###########################################################################
# Lmo package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo.pm
# t/lib/Lmo.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
BEGIN {
$INC{"Lmo.pm"} = __FILE__;
package Lmo;
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
use Lmo::Meta;
use Lmo::Object;
use Lmo::Types;
use Lmo::Utils;
my %export_for;
sub import {
warnings->import(qw(FATAL all));
strict->import();
my $caller = scalar caller(); # Caller's package
my %exports = (
extends => \&extends,
has => \&has,
with => \&with,
override => \&override,
confess => \&Carp::confess,
);
$export_for{$caller} = \%exports;
for my $keyword ( keys %exports ) {
_install_coderef "${caller}::$keyword" => $exports{$keyword};
}
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
@_ = "Lmo::Object";
goto *{ _glob_for "${caller}::extends" }{CODE};
}
}
sub extends {
my $caller = scalar caller();
for my $class ( @_ ) {
_load_module($class);
}
_set_package_isa($caller, @_);
_set_inherited_metadata($caller);
}
sub _load_module {
my ($class) = @_;
(my $file = $class) =~ s{::|'}{/}g;
$file .= '.pm';
{ local $@; eval { require "$file" } } # or warn $@;
return;
}
sub with {
my $package = scalar caller();
require Role::Tiny;
for my $role ( @_ ) {
_load_module($role);
_role_attribute_metadata($package, $role);
}
Role::Tiny->apply_roles_to_package($package, @_);
}
sub _role_attribute_metadata {
my ($package, $role) = @_;
my $package_meta = Lmo::Meta->metadata_for($package);
my $role_meta = Lmo::Meta->metadata_for($role);
%$package_meta = (%$role_meta, %$package_meta);
}
sub has {
my $names = shift;
my $caller = scalar caller();
my $class_metadata = Lmo::Meta->metadata_for($caller);
for my $attribute ( ref $names ? @$names : $names ) {
my %args = @_;
my $method = ($args{is} || '') eq 'ro'
? sub {
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
if $#_;
return $_[0]{$attribute};
}
: sub {
return $#_
? $_[0]{$attribute} = $_[1]
: $_[0]{$attribute};
};
$class_metadata->{$attribute} = ();
if ( my $type_check = $args{isa} ) {
my $check_name = $type_check;
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
}
my $check_sub = sub {
my ($new_val) = @_;
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
};
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
my $orig_method = $method;
$method = sub {
$check_sub->($_[1]) if $#_;
goto &$orig_method;
};
}
if ( my $builder = $args{builder} ) {
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$builder
: goto &$original_method
};
}
if ( my $code = $args{default} ) {
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
unless ref($code) eq 'CODE';
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$code
: goto &$original_method
};
}
if ( my $role = $args{does} ) {
my $original_method = $method;
$method = sub {
if ( $#_ ) {
Carp::confess(qq)
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
}
goto &$original_method
};
}
if ( my $coercion = $args{coerce} ) {
$class_metadata->{$attribute}{coerce} = $coercion;
my $original_method = $method;
$method = sub {
if ( $#_ ) {
return $original_method->($_[0], $coercion->($_[1]))
}
goto &$original_method;
}
}
_install_coderef "${caller}::$attribute" => $method;
if ( $args{required} ) {
$class_metadata->{$attribute}{required} = 1;
}
if ($args{clearer}) {
_install_coderef "${caller}::$args{clearer}"
=> sub { delete shift->{$attribute} }
}
if ($args{predicate}) {
_install_coderef "${caller}::$args{predicate}"
=> sub { exists shift->{$attribute} }
}
if ($args{handles}) {
_has_handles($caller, $attribute, \%args);
}
if (exists $args{init_arg}) {
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
}
}
}
sub _has_handles {
my ($caller, $attribute, $args) = @_;
my $handles = $args->{handles};
my $ref = ref $handles;
my $kv;
if ( $ref eq ref [] ) {
$kv = { map { $_,$_ } @{$handles} };
}
elsif ( $ref eq ref {} ) {
$kv = $handles;
}
elsif ( $ref eq ref qr// ) {
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
unless $args->{isa};
my $target_class = $args->{isa};
$kv = {
map { $_, $_ }
grep { $_ =~ $handles }
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
grep { !$export_for{$target_class}->{$_} }
keys %{ _stash_for $target_class }
};
}
else {
Carp::confess("handles for $ref not yet implemented");
}
while ( my ($method, $target) = each %{$kv} ) {
my $name = _glob_for "${caller}::$method";
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
if defined &$name;
my ($target, @curried_args) = ref($target) ? @$target : $target;
*$name = sub {
my $self = shift;
my $delegate_to = $self->$attribute();
my $error = "Cannot delegate $method to $target because the value of $attribute";
Carp::confess("$error is not defined") unless $delegate_to;
Carp::confess("$error is not an object (got '$delegate_to')")
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
return $delegate_to->$target(@curried_args, @_);
}
}
}
sub _set_package_isa {
my ($package, @new_isa) = @_;
my $package_isa = \*{ _glob_for "${package}::ISA" };
@{*$package_isa} = @new_isa;
}
sub _set_inherited_metadata {
my $class = shift;
my $class_metadata = Lmo::Meta->metadata_for($class);
my $linearized_isa = mro::get_linear_isa($class);
my %new_metadata;
for my $isa_class (reverse @$linearized_isa) {
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
%new_metadata = (
%new_metadata,
%$isa_metadata,
);
}
%$class_metadata = %new_metadata;
}
sub unimport {
my $caller = scalar caller();
my $target = caller;
_unimport_coderefs($target, keys %{$export_for{$caller}});
}
sub Dumper {
require Data::Dumper;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Sortkeys = 0;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_)
}
BEGIN {
if ($] >= 5.010) {
{ local $@; require mro; }
}
else {
local $@;
eval {
require MRO::Compat;
} or do {
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
no strict 'refs';
my $classname = shift;
my @lin = ($classname);
my %stored;
foreach my $parent (@{"$classname\::ISA"}) {
my $plin = mro::get_linear_isa_dfs($parent);
foreach (@$plin) {
next if exists $stored{$_};
push(@lin, $_);
$stored{$_} = 1;
}
}
return \@lin;
};
}
}
}
sub override {
my ($methods, $code) = @_;
my $caller = scalar caller;
for my $method ( ref($methods) ? @$methods : $methods ) {
my $full_method = "${caller}::${method}";
*{_glob_for $full_method} = $code;
}
}
}
1;
}
# ###########################################################################
# End Lmo package
# ###########################################################################
# ###########################################################################
# OptionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/OptionParser.pm
# t/lib/OptionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package OptionParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(max);
use Getopt::Long;
use Data::Dumper;
my $POD_link_re = '[LC]<"?([^">]+)"?>';
sub new {
my ( $class, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($program_name) = $PROGRAM_NAME =~ m/([.A-Za-z-]+)$/;
$program_name ||= $PROGRAM_NAME;
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my %attributes = (
'type' => 1,
'short form' => 1,
'group' => 1,
'default' => 1,
'cumulative' => 1,
'negatable' => 1,
);
my $self = {
head1 => 'OPTIONS', # These args are used internally
skip_rules => 0, # to instantiate another Option-
item => '--(.*)', # Parser obj that parses the
attributes => \%attributes, # DSN OPTIONS section. Tools
parse_attributes => \&_parse_attribs, # don't tinker with these args.
%args,
strict => 1, # disabled by a special rule
program_name => $program_name,
opts => {},
got_opts => 0,
short_opts => {},
defaults => {},
groups => {},
allowed_groups => {},
errors => [],
rules => [], # desc of rules for --help
mutex => [], # rule: opts are mutually exclusive
atleast1 => [], # rule: at least one opt is required
disables => {}, # rule: opt disables other opts
defaults_to => {}, # rule: opt defaults to value of other opt
DSNParser => undef,
default_files => [
"/etc/percona-toolkit/percona-toolkit.conf",
"/etc/percona-toolkit/$program_name.conf",
"$home/.percona-toolkit.conf",
"$home/.$program_name.conf",
],
types => {
string => 's', # standard Getopt type
int => 'i', # standard Getopt type
float => 'f', # standard Getopt type
Hash => 'H', # hash, formed from a comma-separated list
hash => 'h', # hash as above, but only if a value is given
Array => 'A', # array, similar to Hash
array => 'a', # array, similar to hash
DSN => 'd', # DSN
size => 'z', # size with kMG suffix (powers of 2^10)
time => 'm', # time, with an optional suffix of s/h/m/d
},
};
return bless $self, $class;
}
sub get_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
my @specs = $self->_pod_to_specs($file);
$self->_parse_specs(@specs);
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
if ( $contents =~ m/^=head1 DSN OPTIONS/m ) {
PTDEBUG && _d('Parsing DSN OPTIONS');
my $dsn_attribs = {
dsn => 1,
copy => 1,
};
my $parse_dsn_attribs = sub {
my ( $self, $option, $attribs ) = @_;
map {
my $val = $attribs->{$_};
if ( $val ) {
$val = $val eq 'yes' ? 1
: $val eq 'no' ? 0
: $val;
$attribs->{$_} = $val;
}
} keys %$attribs;
return {
key => $option,
%$attribs,
};
};
my $dsn_o = new OptionParser(
description => 'DSN OPTIONS',
head1 => 'DSN OPTIONS',
dsn => 0, # XXX don't infinitely recurse!
item => '\* (.)', # key opts are a single character
skip_rules => 1, # no rules before opts
attributes => $dsn_attribs,
parse_attributes => $parse_dsn_attribs,
);
my @dsn_opts = map {
my $opts = {
key => $_->{spec}->{key},
dsn => $_->{spec}->{dsn},
copy => $_->{spec}->{copy},
desc => $_->{desc},
};
$opts;
} $dsn_o->_pod_to_specs($file);
$self->{DSNParser} = DSNParser->new(opts => \@dsn_opts);
}
if ( $contents =~ m/^=head1 VERSION\n\n^(.+)$/m ) {
$self->{version} = $1;
PTDEBUG && _d($self->{version});
}
return;
}
sub DSNParser {
my ( $self ) = @_;
return $self->{DSNParser};
};
sub get_defaults_files {
my ( $self ) = @_;
return @{$self->{default_files}};
}
sub _pod_to_specs {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my @specs = ();
my @rules = ();
my $para;
local $INPUT_RECORD_SEPARATOR = '';
while ( $para = <$fh> ) {
next unless $para =~ m/^=head1 $self->{head1}/;
last;
}
while ( $para = <$fh> ) {
last if $para =~ m/^=over/;
next if $self->{skip_rules};
chomp $para;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
PTDEBUG && _d('Option rule:', $para);
push @rules, $para;
}
die "POD has no $self->{head1} section" unless $para;
do {
if ( my ($option) = $para =~ m/^=item $self->{item}/ ) {
chomp $para;
PTDEBUG && _d($para);
my %attribs;
$para = <$fh>; # read next paragraph, possibly attributes
if ( $para =~ m/: / ) { # attributes
$para =~ s/\s+\Z//g;
%attribs = map {
my ( $attrib, $val) = split(/: /, $_);
die "Unrecognized attribute for --$option: $attrib"
unless $self->{attributes}->{$attrib};
($attrib, $val);
} split(/; /, $para);
if ( $attribs{'short form'} ) {
$attribs{'short form'} =~ s/-//;
}
$para = <$fh>; # read next paragraph, probably short help desc
}
else {
PTDEBUG && _d('Option has no attributes');
}
$para =~ s/\s+\Z//g;
$para =~ s/\s+/ /g;
$para =~ s/$POD_link_re/$1/go;
$para =~ s/\.(?:\n.*| [A-Z].*|\Z)//s;
PTDEBUG && _d('Short help:', $para);
die "No description after option spec $option" if $para =~ m/^=item/;
if ( my ($base_option) = $option =~ m/^\[no\](.*)/ ) {
$option = $base_option;
$attribs{'negatable'} = 1;
}
push @specs, {
spec => $self->{parse_attributes}->($self, $option, \%attribs),
desc => $para
. (defined $attribs{default} ? " (default $attribs{default})" : ''),
group => ($attribs{'group'} ? $attribs{'group'} : 'default'),
};
}
while ( $para = <$fh> ) {
last unless $para;
if ( $para =~ m/^=head1/ ) {
$para = undef; # Can't 'last' out of a do {} block.
last;
}
last if $para =~ m/^=item /;
}
} while ( $para );
die "No valid specs in $self->{head1}" unless @specs;
close $fh;
return @specs, @rules;
}
sub _parse_specs {
my ( $self, @specs ) = @_;
my %disables; # special rule that requires deferred checking
foreach my $opt ( @specs ) {
if ( ref $opt ) { # It's an option spec, not a rule.
PTDEBUG && _d('Parsing opt spec:',
map { ($_, '=>', $opt->{$_}) } keys %$opt);
my ( $long, $short ) = $opt->{spec} =~ m/^([\w-]+)(?:\|([^!+=]*))?/;
if ( !$long ) {
die "Cannot parse long option from spec $opt->{spec}";
}
$opt->{long} = $long;
die "Duplicate long option --$long" if exists $self->{opts}->{$long};
$self->{opts}->{$long} = $opt;
if ( length $long == 1 ) {
PTDEBUG && _d('Long opt', $long, 'looks like short opt');
$self->{short_opts}->{$long} = $long;
}
if ( $short ) {
die "Duplicate short option -$short"
if exists $self->{short_opts}->{$short};
$self->{short_opts}->{$short} = $long;
$opt->{short} = $short;
}
else {
$opt->{short} = undef;
}
$opt->{is_negatable} = $opt->{spec} =~ m/!/ ? 1 : 0;
$opt->{is_cumulative} = $opt->{spec} =~ m/\+/ ? 1 : 0;
$opt->{is_required} = $opt->{desc} =~ m/required/ ? 1 : 0;
$opt->{group} ||= 'default';
$self->{groups}->{ $opt->{group} }->{$long} = 1;
$opt->{value} = undef;
$opt->{got} = 0;
my ( $type ) = $opt->{spec} =~ m/=(.)/;
$opt->{type} = $type;
PTDEBUG && _d($long, 'type:', $type);
$opt->{spec} =~ s/=./=s/ if ( $type && $type =~ m/[HhAadzm]/ );
if ( (my ($def) = $opt->{desc} =~ m/default\b(?: ([^)]+))?/) ) {
$self->{defaults}->{$long} = defined $def ? $def : 1;
PTDEBUG && _d($long, 'default:', $def);
}
if ( $long eq 'config' ) {
$self->{defaults}->{$long} = join(',', $self->get_defaults_files());
}
if ( (my ($dis) = $opt->{desc} =~ m/(disables .*)/) ) {
$disables{$long} = $dis;
PTDEBUG && _d('Deferring check of disables rule for', $opt, $dis);
}
$self->{opts}->{$long} = $opt;
}
else { # It's an option rule, not a spec.
PTDEBUG && _d('Parsing rule:', $opt);
push @{$self->{rules}}, $opt;
my @participants = $self->_get_participants($opt);
my $rule_ok = 0;
if ( $opt =~ m/mutually exclusive|one and only one/ ) {
$rule_ok = 1;
push @{$self->{mutex}}, \@participants;
PTDEBUG && _d(@participants, 'are mutually exclusive');
}
if ( $opt =~ m/at least one|one and only one/ ) {
$rule_ok = 1;
push @{$self->{atleast1}}, \@participants;
PTDEBUG && _d(@participants, 'require at least one');
}
if ( $opt =~ m/default to/ ) {
$rule_ok = 1;
$self->{defaults_to}->{$participants[0]} = $participants[1];
PTDEBUG && _d($participants[0], 'defaults to', $participants[1]);
}
if ( $opt =~ m/restricted to option groups/ ) {
$rule_ok = 1;
my ($groups) = $opt =~ m/groups ([\w\s\,]+)/;
my @groups = split(',', $groups);
%{$self->{allowed_groups}->{$participants[0]}} = map {
s/\s+//;
$_ => 1;
} @groups;
}
if( $opt =~ m/accepts additional command-line arguments/ ) {
$rule_ok = 1;
$self->{strict} = 0;
PTDEBUG && _d("Strict mode disabled by rule");
}
die "Unrecognized option rule: $opt" unless $rule_ok;
}
}
foreach my $long ( keys %disables ) {
my @participants = $self->_get_participants($disables{$long});
$self->{disables}->{$long} = \@participants;
PTDEBUG && _d('Option', $long, 'disables', @participants);
}
return;
}
sub _get_participants {
my ( $self, $str ) = @_;
my @participants;
foreach my $long ( $str =~ m/--(?:\[no\])?([\w-]+)/g ) {
die "Option --$long does not exist while processing rule $str"
unless exists $self->{opts}->{$long};
push @participants, $long;
}
PTDEBUG && _d('Participants for', $str, ':', @participants);
return @participants;
}
sub opts {
my ( $self ) = @_;
my %opts = %{$self->{opts}};
return %opts;
}
sub short_opts {
my ( $self ) = @_;
my %short_opts = %{$self->{short_opts}};
return %short_opts;
}
sub set_defaults {
my ( $self, %defaults ) = @_;
$self->{defaults} = {};
foreach my $long ( keys %defaults ) {
die "Cannot set default for nonexistent option $long"
unless exists $self->{opts}->{$long};
$self->{defaults}->{$long} = $defaults{$long};
PTDEBUG && _d('Default val for', $long, ':', $defaults{$long});
}
return;
}
sub get_defaults {
my ( $self ) = @_;
return $self->{defaults};
}
sub get_groups {
my ( $self ) = @_;
return $self->{groups};
}
sub _set_option {
my ( $self, $opt, $val ) = @_;
my $long = exists $self->{opts}->{$opt} ? $opt
: exists $self->{short_opts}->{$opt} ? $self->{short_opts}->{$opt}
: die "Getopt::Long gave a nonexistent option: $opt";
$opt = $self->{opts}->{$long};
if ( $opt->{is_cumulative} ) {
$opt->{value}++;
}
elsif ( ($opt->{type} || '') eq 's' && $val =~ m/^--?(.+)/ ) {
my $next_opt = $1;
if ( exists $self->{opts}->{$next_opt}
|| exists $self->{short_opts}->{$next_opt} ) {
$self->save_error("--$long requires a string value");
return;
}
else {
$opt->{value} = $val;
}
}
else {
$opt->{value} = $val;
}
$opt->{got} = 1;
PTDEBUG && _d('Got option', $long, '=', $val);
}
sub get_opts {
my ( $self ) = @_;
foreach my $long ( keys %{$self->{opts}} ) {
$self->{opts}->{$long}->{got} = 0;
$self->{opts}->{$long}->{value}
= exists $self->{defaults}->{$long} ? $self->{defaults}->{$long}
: $self->{opts}->{$long}->{is_cumulative} ? 0
: undef;
}
$self->{got_opts} = 0;
$self->{errors} = [];
if ( @ARGV && $ARGV[0] eq "--config" ) {
shift @ARGV;
$self->_set_option('config', shift @ARGV);
}
if ( $self->has('config') ) {
my @extra_args;
foreach my $filename ( split(',', $self->get('config')) ) {
eval {
push @extra_args, $self->_read_config_file($filename);
};
if ( $EVAL_ERROR ) {
if ( $self->got('config') ) {
die $EVAL_ERROR;
}
elsif ( PTDEBUG ) {
_d($EVAL_ERROR);
}
}
}
unshift @ARGV, @extra_args;
}
Getopt::Long::Configure('no_ignore_case', 'bundling');
GetOptions(
map { $_->{spec} => sub { $self->_set_option(@_); } }
grep { $_->{long} ne 'config' } # --config is handled specially above.
values %{$self->{opts}}
) or $self->save_error('Error parsing options');
if ( exists $self->{opts}->{version} && $self->{opts}->{version}->{got} ) {
if ( $self->{version} ) {
print $self->{version}, "\n";
}
else {
print "Error parsing version. See the VERSION section of the tool's documentation.\n";
}
exit 1;
}
if ( @ARGV && $self->{strict} ) {
$self->save_error("Unrecognized command-line options @ARGV");
}
foreach my $mutex ( @{$self->{mutex}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$mutex;
if ( @set > 1 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$mutex}[ 0 .. scalar(@$mutex) - 2] )
. ' and --'.$self->{opts}->{$mutex->[-1]}->{long}
. ' are mutually exclusive.';
$self->save_error($err);
}
}
foreach my $required ( @{$self->{atleast1}} ) {
my @set = grep { $self->{opts}->{$_}->{got} } @$required;
if ( @set == 0 ) {
my $err = join(', ', map { "--$self->{opts}->{$_}->{long}" }
@{$required}[ 0 .. scalar(@$required) - 2] )
.' or --'.$self->{opts}->{$required->[-1]}->{long};
$self->save_error("Specify at least one of $err");
}
}
$self->_check_opts( keys %{$self->{opts}} );
$self->{got_opts} = 1;
return;
}
sub _check_opts {
my ( $self, @long ) = @_;
my $long_last = scalar @long;
while ( @long ) {
foreach my $i ( 0..$#long ) {
my $long = $long[$i];
next unless $long;
my $opt = $self->{opts}->{$long};
if ( $opt->{got} ) {
if ( exists $self->{disables}->{$long} ) {
my @disable_opts = @{$self->{disables}->{$long}};
map { $self->{opts}->{$_}->{value} = undef; } @disable_opts;
PTDEBUG && _d('Unset options', @disable_opts,
'because', $long,'disables them');
}
if ( exists $self->{allowed_groups}->{$long} ) {
my @restricted_groups = grep {
!exists $self->{allowed_groups}->{$long}->{$_}
} keys %{$self->{groups}};
my @restricted_opts;
foreach my $restricted_group ( @restricted_groups ) {
RESTRICTED_OPT:
foreach my $restricted_opt (
keys %{$self->{groups}->{$restricted_group}} )
{
next RESTRICTED_OPT if $restricted_opt eq $long;
push @restricted_opts, $restricted_opt
if $self->{opts}->{$restricted_opt}->{got};
}
}
if ( @restricted_opts ) {
my $err;
if ( @restricted_opts == 1 ) {
$err = "--$restricted_opts[0]";
}
else {
$err = join(', ',
map { "--$self->{opts}->{$_}->{long}" }
grep { $_ }
@restricted_opts[0..scalar(@restricted_opts) - 2]
)
. ' or --'.$self->{opts}->{$restricted_opts[-1]}->{long};
}
$self->save_error("--$long is not allowed with $err");
}
}
}
elsif ( $opt->{is_required} ) {
$self->save_error("Required option --$long must be specified");
}
$self->_validate_type($opt);
if ( $opt->{parsed} ) {
delete $long[$i];
}
else {
PTDEBUG && _d('Temporarily failed to parse', $long);
}
}
die "Failed to parse options, possibly due to circular dependencies"
if @long == $long_last;
$long_last = @long;
}
return;
}
sub _validate_type {
my ( $self, $opt ) = @_;
return unless $opt;
if ( !$opt->{type} ) {
$opt->{parsed} = 1;
return;
}
my $val = $opt->{value};
if ( $val && $opt->{type} eq 'm' ) { # type time
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a time value');
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
if ( !$suffix ) {
my ( $s ) = $opt->{desc} =~ m/\(suffix (.)\)/;
$suffix = $s || 's';
PTDEBUG && _d('No suffix given; using', $suffix, 'for',
$opt->{long}, '(value:', $val, ')');
}
if ( $suffix =~ m/[smhd]/ ) {
$val = $suffix eq 's' ? $num # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$opt->{value} = ($prefix || '') . $val;
PTDEBUG && _d('Setting option', $opt->{long}, 'to', $val);
}
else {
$self->save_error("Invalid time suffix for --$opt->{long}");
}
}
elsif ( $val && $opt->{type} eq 'd' ) { # type DSN
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a DSN');
my $prev = {};
my $from_key = $self->{defaults_to}->{ $opt->{long} };
if ( $from_key ) {
PTDEBUG && _d($opt->{long}, 'DSN copies from', $from_key, 'DSN');
if ( $self->{opts}->{$from_key}->{parsed} ) {
$prev = $self->{opts}->{$from_key}->{value};
}
else {
PTDEBUG && _d('Cannot parse', $opt->{long}, 'until',
$from_key, 'parsed');
return;
}
}
my $defaults = $self->{DSNParser}->parse_options($self);
$opt->{value} = $self->{DSNParser}->parse($val, $prev, $defaults);
}
elsif ( $val && $opt->{type} eq 'z' ) { # type size
PTDEBUG && _d('Parsing option', $opt->{long}, 'as a size value');
$self->_parse_size($opt, $val);
}
elsif ( $opt->{type} eq 'H' || (defined $val && $opt->{type} eq 'h') ) {
$opt->{value} = { map { $_ => 1 } split(/(?{type} eq 'A' || (defined $val && $opt->{type} eq 'a') ) {
$opt->{value} = [ split(/(?{long}, 'type', $opt->{type}, 'value', $val);
}
$opt->{parsed} = 1;
return;
}
sub get {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{value};
}
sub got {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
return $self->{opts}->{$long}->{got};
}
sub has {
my ( $self, $opt ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
return defined $long ? exists $self->{opts}->{$long} : 0;
}
sub set {
my ( $self, $opt, $val ) = @_;
my $long = (length $opt == 1 ? $self->{short_opts}->{$opt} : $opt);
die "Option $opt does not exist"
unless $long && exists $self->{opts}->{$long};
$self->{opts}->{$long}->{value} = $val;
return;
}
sub save_error {
my ( $self, $error ) = @_;
push @{$self->{errors}}, $error;
return;
}
sub errors {
my ( $self ) = @_;
return $self->{errors};
}
sub usage {
my ( $self ) = @_;
warn "No usage string is set" unless $self->{usage}; # XXX
return "Usage: " . ($self->{usage} || '') . "\n";
}
sub descr {
my ( $self ) = @_;
warn "No description string is set" unless $self->{description}; # XXX
my $descr = ($self->{description} || $self->{program_name} || '')
. " For more details, please use the --help option, "
. "or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation.";
$descr = join("\n", $descr =~ m/(.{0,80})(?:\s+|$)/g)
unless $ENV{DONT_BREAK_LINES};
$descr =~ s/ +$//mg;
return $descr;
}
sub usage_or_errors {
my ( $self, $file, $return ) = @_;
$file ||= $self->{file} || __FILE__;
if ( !$self->{description} || !$self->{usage} ) {
PTDEBUG && _d("Getting description and usage from SYNOPSIS in", $file);
my %synop = $self->_parse_synopsis($file);
$self->{description} ||= $synop{description};
$self->{usage} ||= $synop{usage};
PTDEBUG && _d("Description:", $self->{description},
"\nUsage:", $self->{usage});
}
if ( $self->{opts}->{help}->{got} ) {
print $self->print_usage() or die "Cannot print usage: $OS_ERROR";
exit 0 unless $return;
}
elsif ( scalar @{$self->{errors}} ) {
print $self->print_errors() or die "Cannot print errors: $OS_ERROR";
exit 1 unless $return;
}
return;
}
sub print_errors {
my ( $self ) = @_;
my $usage = $self->usage() . "\n";
if ( (my @errors = @{$self->{errors}}) ) {
$usage .= join("\n * ", 'Errors in command-line arguments:', @errors)
. "\n";
}
return $usage . "\n" . $self->descr();
}
sub print_usage {
my ( $self ) = @_;
die "Run get_opts() before print_usage()" unless $self->{got_opts};
my @opts = values %{$self->{opts}};
my $maxl = max(
map {
length($_->{long}) # option long name
+ ($_->{is_negatable} ? 4 : 0) # "[no]" if opt is negatable
+ ($_->{type} ? 2 : 0) # "=x" where x is the opt type
}
@opts);
my $maxs = max(0,
map {
length($_)
+ ($self->{opts}->{$_}->{is_negatable} ? 4 : 0)
+ ($self->{opts}->{$_}->{type} ? 2 : 0)
}
values %{$self->{short_opts}});
my $lcol = max($maxl, ($maxs + 3));
my $rcol = 80 - $lcol - 6;
my $rpad = ' ' x ( 80 - $rcol );
$maxs = max($lcol - 3, $maxs);
my $usage = $self->descr() . "\n" . $self->usage();
my @groups = reverse sort grep { $_ ne 'default'; } keys %{$self->{groups}};
push @groups, 'default';
foreach my $group ( reverse @groups ) {
$usage .= "\n".($group eq 'default' ? 'Options' : $group).":\n\n";
foreach my $opt (
sort { $a->{long} cmp $b->{long} }
grep { $_->{group} eq $group }
@opts )
{
my $long = $opt->{is_negatable} ? "[no]$opt->{long}" : $opt->{long};
my $short = $opt->{short};
my $desc = $opt->{desc};
$long .= $opt->{type} ? "=$opt->{type}" : "";
if ( $opt->{type} && $opt->{type} eq 'm' ) {
my ($s) = $desc =~ m/\(suffix (.)\)/;
$s ||= 's';
$desc =~ s/\s+\(suffix .\)//;
$desc .= ". Optional suffix s=seconds, m=minutes, h=hours, "
. "d=days; if no suffix, $s is used.";
}
$desc = join("\n$rpad", grep { $_ } $desc =~ m/(.{0,$rcol}(?!\W))(?:\s+|(?<=\W)|$)/g);
$desc =~ s/ +$//mg;
if ( $short ) {
$usage .= sprintf(" --%-${maxs}s -%s %s\n", $long, $short, $desc);
}
else {
$usage .= sprintf(" --%-${lcol}s %s\n", $long, $desc);
}
}
}
$usage .= "\nOption types: s=string, i=integer, f=float, h/H/a/A=comma-separated list, d=DSN, z=size, m=time\n";
if ( (my @rules = @{$self->{rules}}) ) {
$usage .= "\nRules:\n\n";
$usage .= join("\n", map { " $_" } @rules) . "\n";
}
if ( $self->{DSNParser} ) {
$usage .= "\n" . $self->{DSNParser}->usage();
}
$usage .= "\nOptions and values after processing arguments:\n\n";
foreach my $opt ( sort { $a->{long} cmp $b->{long} } @opts ) {
my $val = $opt->{value};
my $type = $opt->{type} || '';
my $bool = $opt->{spec} =~ m/^[\w-]+(?:\|[\w-])?!?$/;
$val = $bool ? ( $val ? 'TRUE' : 'FALSE' )
: !defined $val ? '(No value)'
: $type eq 'd' ? $self->{DSNParser}->as_string($val)
: $type =~ m/H|h/ ? join(',', sort keys %$val)
: $type =~ m/A|a/ ? join(',', @$val)
: $val;
$usage .= sprintf(" --%-${lcol}s %s\n", $opt->{long}, $val);
}
return $usage;
}
sub prompt_noecho {
shift @_ if ref $_[0] eq __PACKAGE__;
my ( $prompt ) = @_;
local $OUTPUT_AUTOFLUSH = 1;
print STDERR $prompt
or die "Cannot print: $OS_ERROR";
my $response;
eval {
require Term::ReadKey;
Term::ReadKey::ReadMode('noecho');
chomp($response = );
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# Cxn package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Cxn.pm
# t/lib/Cxn.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Cxn;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Scalar::Util qw(blessed);
use constant {
PTDEBUG => $ENV{PTDEBUG} || 0,
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
};
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(DSNParser OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($dp, $o) = @args{@required_args};
my $dsn_defaults = $dp->parse_options($o);
my $prev_dsn = $args{prev_dsn};
my $dsn = $args{dsn};
if ( !$dsn ) {
$args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
$dsn = $dp->parse(
$args{dsn_string}, $prev_dsn, $dsn_defaults);
}
elsif ( $prev_dsn ) {
$dsn = $dp->copy($prev_dsn, $dsn);
}
my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
my $self = {
dsn => $dsn,
dbh => $args{dbh},
dsn_name => $dsn_name,
hostname => '',
set => $args{set},
NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
dbh_set => 0,
ask_pass => $o->get('ask-pass'),
DSNParser => $dp,
is_cluster_node => undef,
parent => $args{parent},
};
return bless $self, $class;
}
sub connect {
my ( $self, %opts ) = @_;
my $dsn = $opts{dsn} || $self->{dsn};
my $dp = $self->{DSNParser};
my $dbh = $self->{dbh};
if ( !$dbh || !$dbh->ping() ) {
if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) {
$dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
$self->{asked_for_pass} = 1;
}
$dbh = $dp->get_dbh(
$dp->get_cxn_params($dsn),
{
AutoCommit => 1,
%opts,
},
);
}
$dbh = $self->set_dbh($dbh);
if ( $opts{dsn} ) {
$self->{dsn} = $dsn;
$self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
}
PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
return $dbh;
}
sub set_dbh {
my ($self, $dbh) = @_;
if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
PTDEBUG && _d($dbh, 'Already set dbh');
return $dbh;
}
PTDEBUG && _d($dbh, 'Setting dbh');
$dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
PTDEBUG && _d($dbh, $sql);
my ($server_id, $hostname) = $dbh->selectrow_array($sql);
PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
if ( $hostname ) {
$self->{hostname} = $hostname;
}
if ( $self->{parent} ) {
PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
$dbh->{InactiveDestroy} = 1;
}
if ( my $set = $self->{set}) {
$set->($dbh);
}
$self->{dbh} = $dbh;
$self->{dbh_set} = 1;
return $dbh;
}
sub lost_connection {
my ($self, $e) = @_;
return 0 unless $e;
return $e =~ m/MySQL server has gone away/
|| $e =~ m/Lost connection to MySQL server/;
}
sub dbh {
my ($self) = @_;
return $self->{dbh};
}
sub dsn {
my ($self) = @_;
return $self->{dsn};
}
sub name {
my ($self) = @_;
return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
return $self->{hostname} || $self->{dsn_name} || 'unknown host';
}
sub get_id {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $unique_id;
if ($cxn->is_cluster_node()) { # for cluster we concatenate various variables to maximize id 'uniqueness' across versions
my $sql = q{SHOW STATUS LIKE 'wsrep\_local\_index'};
my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql);
PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index);
$unique_id = $wsrep_local_index."|";
foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
my $sql = "SHOW VARIABLES LIKE '$val'";
PTDEBUG && _d($cxn->name, $sql);
my (undef, $val) = $cxn->dbh->selectrow_array($sql);
$unique_id .= "|$val";
}
} else {
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
$unique_id = $cxn->dbh->selectrow_array($sql);
}
PTDEBUG && _d("Generated unique id for cluster:", $unique_id);
return $unique_id;
}
sub is_cluster_node {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
PTDEBUG && _d($cxn->name, $sql);
my $row = $cxn->dbh->selectrow_arrayref($sql);
return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0;
}
sub remove_duplicate_cxns {
my ($self, %args) = @_;
my @cxns = @{$args{cxns}};
my $seen_ids = $args{seen_ids} || {};
PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
my @trimmed_cxns;
for my $cxn ( @cxns ) {
my $id = $cxn->get_id();
PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
if ( ! $seen_ids->{$id}++ ) {
push @trimmed_cxns, $cxn
}
else {
PTDEBUG && _d("Removing ", $cxn->name,
", ID ", $id, ", because we've already seen it");
}
}
return \@trimmed_cxns;
}
sub DESTROY {
my ($self) = @_;
PTDEBUG && _d('Destroying cxn');
if ( $self->{parent} ) {
PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
}
elsif ( $self->{dbh}
&& blessed($self->{dbh})
&& $self->{dbh}->can("disconnect") )
{
PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
$self->{dsn_name});
$self->{dbh}->disconnect();
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Cxn package
# ###########################################################################
# ###########################################################################
# Daemon package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Daemon.pm
# t/lib/Daemon.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Daemon;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(setsid);
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(o) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $o = $args{o};
my $self = {
o => $o,
log_file => $o->has('log') ? $o->get('log') : undef,
PID_file => $o->has('pid') ? $o->get('pid') : undef,
};
check_PID_file(undef, $self->{PID_file});
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
return bless $self, $class;
}
sub daemonize {
my ( $self ) = @_;
PTDEBUG && _d('About to fork and daemonize');
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $pid ) {
PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
exit;
}
PTDEBUG && _d('Daemonizing child PID', $PID);
$self->{PID_owner} = $PID;
$self->{child} = 1;
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
$self->_make_PID_file();
$OUTPUT_AUTOFLUSH = 1;
PTDEBUG && _d('Redirecting STDIN to /dev/null');
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
if ( $self->{log_file} ) {
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
close STDOUT;
open STDOUT, '>>', $self->{log_file}
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
close STDERR;
open STDERR, ">&STDOUT"
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
}
else {
if ( -t STDOUT ) {
PTDEBUG && _d('No log file and STDOUT is a terminal;',
'redirecting to /dev/null');
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
PTDEBUG && _d('No log file and STDERR is a terminal;',
'redirecting to /dev/null');
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
return;
}
sub check_PID_file {
my ( $self, $file ) = @_;
my $PID_file = $self ? $self->{PID_file} : $file;
PTDEBUG && _d('Checking PID file', $PID_file);
if ( $PID_file && -f $PID_file ) {
my $pid;
eval {
chomp($pid = (slurp_file($PID_file) || ''));
};
if ( $EVAL_ERROR ) {
die "The PID file $PID_file already exists but it cannot be read: "
. $EVAL_ERROR;
}
PTDEBUG && _d('PID file exists; it contains PID', $pid);
if ( $pid ) {
my $pid_is_alive = kill 0, $pid;
if ( $pid_is_alive ) {
die "The PID file $PID_file already exists "
. " and the PID that it contains, $pid, is running";
}
else {
warn "Overwriting PID file $PID_file because the PID that it "
. "contains, $pid, is not running";
}
}
else {
die "The PID file $PID_file already exists but it does not "
. "contain a PID";
}
}
else {
PTDEBUG && _d('No PID file');
}
return;
}
sub make_PID_file {
my ( $self ) = @_;
if ( exists $self->{child} ) {
die "Do not call Daemon::make_PID_file() for daemonized scripts";
}
$self->_make_PID_file();
$self->{PID_owner} = $PID;
return;
}
sub _make_PID_file {
my ( $self ) = @_;
my $PID_file = $self->{PID_file};
if ( !$PID_file ) {
PTDEBUG && _d('No PID file to create');
return;
}
$self->check_PID_file();
open my $PID_FH, '>', $PID_file
or die "Cannot open PID file $PID_file: $OS_ERROR";
print $PID_FH $PID
or die "Cannot print to PID file $PID_file: $OS_ERROR";
close $PID_FH
or die "Cannot close PID file $PID_file: $OS_ERROR";
PTDEBUG && _d('Created PID file:', $self->{PID_file});
return;
}
sub _remove_PID_file {
my ( $self ) = @_;
if ( $self->{PID_file} && -f $self->{PID_file} ) {
unlink $self->{PID_file}
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
PTDEBUG && _d('Removed PID file');
}
else {
PTDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ( $self ) = @_;
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
return;
}
sub slurp_file {
my ($file) = @_;
return unless $file;
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
return do { local $/; <$fh> };
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Daemon package
# ###########################################################################
# ###########################################################################
# TextResultSetParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/TextResultSetParser.pm
# t/lib/TextResultSetParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package TextResultSetParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my %value_for = (
'NULL' => undef, # DBI::selectall_arrayref() does this
($args{value_for} ? %{$args{value_for}} : ()),
);
my $self = {
%args,
value_for => \%value_for,
};
return bless $self, $class;
}
sub _parse_tabular {
my ( $text, @cols ) = @_;
my %row;
my @vals = $text =~ m/\| +([^\|]*?)(?= +\|)/msg;
return (undef, \@vals) unless @cols;
@row{@cols} = @vals;
return (\%row, undef);
}
sub _parse_tab_sep {
my ( $text, @cols ) = @_;
my %row;
my @vals = split(/\t/, $text);
return (undef, \@vals) unless @cols;
@row{@cols} = @vals;
return (\%row, undef);
}
sub parse_vertical_row {
my ( $self, $text ) = @_;
my %row = $text =~ m/^\s*(\w+):(?: ([^\n]*))?/msg;
if ( $self->{NAME_lc} ) {
my %lc_row = map {
my $key = lc $_;
$key => $row{$_};
} keys %row;
return \%lc_row;
}
else {
return \%row;
}
}
sub parse {
my ( $self, $text ) = @_;
my $result_set;
if ( $text =~ m/^\+---/m ) { # standard "tabular" output
PTDEBUG && _d('Result set text is standard tabular');
my $line_pattern = qr/^(\| .*)[\r\n]+/m;
$result_set
= $self->parse_horizontal_row($text, $line_pattern, \&_parse_tabular);
}
elsif ( $text =~ m/^\w+\t\w+/m ) { # tab-separated
PTDEBUG && _d('Result set text is tab-separated');
my $line_pattern = qr/^(.*?\t.*)[\r\n]+/m;
$result_set
= $self->parse_horizontal_row($text, $line_pattern, \&_parse_tab_sep);
}
elsif ( $text =~ m/\*\*\* \d+\. row/ ) { # "vertical" output
PTDEBUG && _d('Result set text is vertical (\G)');
foreach my $row ( split_vertical_rows($text) ) {
push @$result_set, $self->parse_vertical_row($row);
}
}
else {
my $text_sample = substr $text, 0, 300;
my $remaining = length $text > 300 ? (length $text) - 300 : 0;
chomp $text_sample;
die "Cannot determine if text is tabular, tab-separated or vertical:\n"
. "$text_sample\n"
. ($remaining ? "(not showing last $remaining bytes of text)\n" : "");
}
if ( $self->{value_for} ) {
foreach my $result_set ( @$result_set ) {
foreach my $key ( keys %$result_set ) {
next unless defined $result_set->{$key};
$result_set->{$key} = $self->{value_for}->{ $result_set->{$key} }
if exists $self->{value_for}->{ $result_set->{$key} };
}
}
}
return $result_set;
}
sub parse_horizontal_row {
my ( $self, $text, $line_pattern, $sub ) = @_;
my @result_sets = ();
my @cols = ();
foreach my $line ( $text =~ m/$line_pattern/g ) {
my ( $row, $cols ) = $sub->($line, @cols);
if ( $row ) {
push @result_sets, $row;
}
else {
@cols = map { $self->{NAME_lc} ? lc $_ : $_ } @$cols;
}
}
return \@result_sets;
}
sub split_vertical_rows {
my ( $text ) = @_;
my $ROW_HEADER = '\*{3,} \d+\. row \*{3,}';
my @rows = $text =~ m/($ROW_HEADER.*?)(?=$ROW_HEADER|\z)/omgs;
return @rows;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TextResultSetParser package
# ###########################################################################
# ###########################################################################
# MySQLConfig package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MySQLConfig.pm
# t/lib/MySQLConfig.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MySQLConfig;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
my %can_be_duplicate = (
replicate_wild_do_table => 1,
replicate_wild_ignore_table => 1,
replicate_rewrite_db => 1,
replicate_ignore_table => 1,
replicate_ignore_db => 1,
replicate_do_table => 1,
replicate_do_db => 1,
);
sub new {
my ( $class, %args ) = @_;
my @requires_one_of = qw(file output result_set dbh);
my $required_arg = grep { $args{$_} } @requires_one_of;
if ( !$required_arg ) {
die "I need a " . join(', ', @requires_one_of[0..$#requires_one_of-1])
. " or " . $requires_one_of[-1] . " argument";
}
if ( $required_arg > 1 ) {
die "Specify only one "
. join(', ', @requires_one_of[0..$#requires_one_of-1])
. " or " . $requires_one_of[-1] . " argument";
}
if ( $args{file} || $args{output} ) {
die "I need a TextResultSetParser argument"
unless $args{TextResultSetParser};
}
if ( $args{file} ) {
$args{output} = _slurp_file($args{file});
}
my %config_data = _parse_config(%args);
my $self = {
%args,
%config_data,
};
return bless $self, $class;
}
sub _parse_config {
my ( %args ) = @_;
my %config_data;
if ( $args{output} ) {
%config_data = _parse_config_output(%args);
}
elsif ( my $rows = $args{result_set} ) {
$config_data{format} = $args{format} || 'show_variables';
$config_data{vars} = { map { @$_ } @$rows };
}
elsif ( my $dbh = $args{dbh} ) {
$config_data{format} = $args{format} || 'show_variables';
my $sql = "SHOW /*!40103 GLOBAL*/ VARIABLES";
PTDEBUG && _d($dbh, $sql);
my $rows = $dbh->selectall_arrayref($sql);
$config_data{vars} = { map { @$_ } @$rows };
$config_data{mysql_version} = _get_version($dbh);
}
else {
die "Unknown config source";
}
handle_special_vars(\%config_data);
return %config_data;
}
sub handle_special_vars {
my ($config_data) = @_;
if ( $config_data->{vars}->{wsrep_provider_options} ) {
my $vars = $config_data->{vars};
my $dupes = $config_data->{duplicate_vars};
for my $wpo ( $vars->{wsrep_provider_options}, @{$dupes->{wsrep_provider_options} || [] } ) {
my %opts = $wpo =~ /(\S+)\s*=\s*(\S*)(?:;|;?$)/g;
while ( my ($var, $val) = each %opts ) {
$val =~ s/;$//;
if ( exists $vars->{$var} ) {
push @{$dupes->{$var} ||= []}, $val;
}
$vars->{$var} = $val;
}
}
delete $vars->{wsrep_provider_options};
}
return;
}
sub _parse_config_output {
my ( %args ) = @_;
my @required_args = qw(output TextResultSetParser);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
PTDEBUG && _d("Parsing config output");
my $format = $args{format} || detect_config_output_format(%args);
if ( !$format ) {
die "Cannot auto-detect the MySQL config format";
}
my $vars; # variables hashref
my $dupes; # duplicate vars hashref
my $opt_files; # option files arrayref
if ( $format eq 'show_variables' ) {
$vars = parse_show_variables(%args);
}
elsif ( $format eq 'mysqld' ) {
($vars, $opt_files) = parse_mysqld(%args);
}
elsif ( $format eq 'my_print_defaults' ) {
($vars, $dupes) = parse_my_print_defaults(%args);
}
elsif ( $format eq 'option_file' ) {
($vars, $dupes) = parse_option_file(%args);
}
else {
die "Invalid MySQL config format: $format";
}
die "Failed to parse MySQL config" unless $vars && keys %$vars;
if ( $format ne 'show_variables' ) {
_mimic_show_variables(
%args,
format => $format,
vars => $vars,
);
}
return (
format => $format,
vars => $vars,
option_files => $opt_files,
duplicate_vars => $dupes,
);
}
sub detect_config_output_format {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my $format;
if ( $output =~ m/\|\s+\w+\s+\|\s+.+?\|/
|| $output =~ m/\*+ \d/
|| $output =~ m/Variable_name:\s+\w+/
|| $output =~ m/Variable_name\s+Value$/m )
{
PTDEBUG && _d('show variables format');
$format = 'show_variables';
}
elsif ( $output =~ m/Starts the MySQL database server/
|| $output =~ m/Default options are read from /
|| $output =~ m/^help\s+TRUE /m )
{
PTDEBUG && _d('mysqld format');
$format = 'mysqld';
}
elsif ( $output =~ m/^--\w+/m ) {
PTDEBUG && _d('my_print_defaults format');
$format = 'my_print_defaults';
}
elsif ( $output =~ m/^\s*\[[a-zA-Z]+\]\s*$/m ) {
PTDEBUG && _d('option file format');
$format = 'option_file',
}
return $format;
}
sub parse_show_variables {
my ( %args ) = @_;
my @required_args = qw(output TextResultSetParser);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output, $trp) = @args{@required_args};
my %config = map {
$_->{Variable_name} => $_->{Value}
} @{ $trp->parse($output) };
return \%config;
}
sub parse_mysqld {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my @opt_files;
if ( $output =~ m/^Default options are read.+\n/mg ) {
my ($opt_files) = $output =~ m/\G^(.+)\n/m;
my %seen;
my @opt_files = grep { !$seen{$_} } split(' ', $opt_files);
PTDEBUG && _d('Option files:', @opt_files);
}
else {
PTDEBUG && _d("mysqld help output doesn't list option files");
}
if ( $output !~ m/^-+ -+$(.+?)(?:\n\n.+)?\z/sm ) {
PTDEBUG && _d("mysqld help output doesn't list vars and vals");
return;
}
my $varvals = $1;
my ($config, undef) = _parse_varvals(
qr/^(\S+)(.*)$/,
$varvals,
);
return $config, \@opt_files;
}
sub parse_my_print_defaults {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my ($config, $dupes) = _parse_varvals(
qr/^--([^=]+)(?:=(.*))?$/,
$output,
);
return $config, $dupes;
}
sub parse_option_file {
my ( %args ) = @_;
my @required_args = qw(output);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($output) = @args{@required_args};
my ($mysqld_section) = $output =~ m/\[mysqld\](.+?)(?:^\s*\[\w+\]|\Z)/xms;
die "Failed to parse the [mysqld] section" unless $mysqld_section;
my ($config, $dupes) = _parse_varvals(
qr/^([^=]+)(?:=(.*))?$/,
$mysqld_section,
);
return $config, $dupes;
}
sub _preprocess_varvals {
my ($re, $to_parse) = @_;
my %vars;
LINE:
foreach my $line ( split /\n/, $to_parse ) {
next LINE if $line =~ m/^\s*$/; # no empty lines
next LINE if $line =~ /^\s*[#;]/; # no # or ; comment lines
if ( $line !~ $re ) {
PTDEBUG && _d("Line <", $line, "> didn't match $re");
next LINE;
}
my ($var, $val) = ($1, $2);
$var =~ tr/-/_/;
$var =~ s/\s*#.*$//;
if ( !defined $val ) {
$val = '';
}
for my $item ($var, $val) {
$item =~ s/^\s+//;
$item =~ s/\s+$//;
}
push @{$vars{$var} ||= []}, $val
}
return \%vars;
}
sub _parse_varvals {
my ( $vars ) = _preprocess_varvals(@_);
my %config;
my %duplicates;
while ( my ($var, $vals) = each %$vars ) {
my $val = _process_val( pop @$vals );
if ( @$vals && !$can_be_duplicate{$var} ) {
PTDEBUG && _d("Duplicate var:", $var);
foreach my $current_val ( map { _process_val($_) } @$vals ) {
push @{$duplicates{$var} ||= []}, $current_val;
}
}
PTDEBUG && _d("Var:", $var, "val:", $val);
$config{$var} = $val;
}
return \%config, \%duplicates;
}
my $quote_re = qr/
\A # Start of value
(['"]) # Opening quote
(.*) # Value
\1 # Closing quote
\s*(?:\#.*)? # End of line comment
[\n\r]*\z # End of value
/x;
sub _process_val {
my ($val) = @_;
if ( $val =~ $quote_re ) {
$val = $2;
}
else {
$val =~ s/\s*#.*//;
}
if ( my ($num, $factor) = $val =~ m/(\d+)([KMGT])b?$/i ) {
my %factor_for = (
k => 1_024,
m => 1_048_576,
g => 1_073_741_824,
t => 1_099_511_627_776,
);
$val = $num * $factor_for{lc $factor};
}
elsif ( $val =~ m/No default/ ) {
$val = '';
}
return $val;
}
sub _mimic_show_variables {
my ( %args ) = @_;
my @required_args = qw(vars format);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($vars, $format) = @args{@required_args};
foreach my $var ( keys %$vars ) {
if ( $vars->{$var} eq '' ) {
if ( $format eq 'mysqld' ) {
if ( $var ne 'log_error' && $var =~ m/^(?:log|skip|ignore)/ ) {
$vars->{$var} = 'OFF';
}
}
else {
$vars->{$var} = 'ON';
}
}
}
return;
}
sub _slurp_file {
my ( $file ) = @_;
die "I need a file argument" unless $file;
PTDEBUG && _d("Reading", $file);
open my $fh, '<', $file or die "Cannot open $file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
return $contents;
}
sub _get_version {
my ( $dbh ) = @_;
return unless $dbh;
my $version = $dbh->selectrow_arrayref('SELECT VERSION()')->[0];
$version =~ s/(\d\.\d{1,2}.\d{1,2})/$1/;
PTDEBUG && _d('MySQL version', $version);
return $version;
}
sub has {
my ( $self, $var ) = @_;
return exists $self->{vars}->{$var};
}
sub value_of {
my ( $self, $var ) = @_;
return unless $var;
return $self->{vars}->{$var};
}
sub variables {
my ( $self, %args ) = @_;
return $self->{vars};
}
sub duplicate_variables {
my ( $self ) = @_;
return $self->{duplicate_vars};
}
sub option_files {
my ( $self ) = @_;
return $self->{option_files};
}
sub mysql_version {
my ( $self ) = @_;
return $self->{mysql_version};
}
sub format {
my ( $self ) = @_;
return $self->{format};
}
sub is_active {
my ( $self ) = @_;
return $self->{dbh} ? 1 : 0;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MySQLConfig package
# ###########################################################################
# ###########################################################################
# MySQLConfigComparer package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MySQLConfigComparer.pm
# t/lib/MySQLConfigComparer.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MySQLConfigComparer;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
my %alt_val_for = (
ON => 1,
YES => 1,
TRUE => 1,
OFF => 0,
NO => 0,
FALSE => 0,
);
sub new {
my ( $class, %args ) = @_;
my %ignore_vars = (
date_format => 1,
datetime_format => 1,
ft_stopword_file => 1,
timestamp => 1,
time_format => 1,
($args{ignore_variables}
? map { $_ => 1 } @{$args{ignore_variables}}
: ()),
);
my %is_numeric = (
long_query_time => 1,
($args{numeric_variables}
? map { $_ => 1 } @{$args{numeric_variables}}
: ()),
);
my %value_is_optional = (
log_error => 1,
log_isam => 1,
($args{optional_value_variables}
? map { $_ => 1 } @{$args{optional_value_variables}}
: ()),
);
my %any_value_is_true = (
log => 1,
log_bin => 1,
log_slow_queries => 1,
($args{any_value_is_true_variables}
? map { $_ => 1 } @{$args{any_value_is_true_variables}}
: ()),
);
my %base_path = (
character_sets_dir => 'basedir',
datadir => 'basedir',
general_log_file => 'datadir',
language => 'basedir',
log_error => 'datadir',
pid_file => 'datadir',
plugin_dir => 'basedir',
slow_query_log_file => 'datadir',
socket => 'datadir',
($args{base_paths}
? map { $_ => 1 } @{$args{base_paths}}
: ()),
);
my $self = {
ignore_vars => \%ignore_vars,
is_numeric => \%is_numeric,
value_is_optional => \%value_is_optional,
any_value_is_true => \%any_value_is_true,
base_path => \%base_path,
ignore_case => exists $args{ignore_case}
? $args{ignore_case}
: 1,
};
return bless $self, $class;
}
sub diff {
my ( $self, %args ) = @_;
my @required_args = qw(configs);
foreach my $arg( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($configs) = @args{@required_args};
if ( @$configs < 2 ) {
PTDEBUG && _d("Less than two MySQLConfig objects; nothing to compare");
return;
}
my $base_path = $self->{base_path};
my $is_numeric = $self->{is_numeric};
my $any_value_is_true = $self->{any_value_is_true};
my $value_is_optional = $self->{value_is_optional};
my $config0 = $configs->[0];
my $last_config = @$configs - 1;
my $vars = $self->_get_shared_vars(%args);
my $ignore_case = $self->{ignore_case};
my $diffs;
VARIABLE:
foreach my $var ( @$vars ) {
my $is_dir = $var =~ m/dir$/ || $var eq 'language';
my $val0 = $self->_normalize_value( # config0 value
value => $config0->value_of($var),
is_directory => $is_dir,
base_path => $config0->value_of($base_path->{$var}) || "",
);
eval {
CONFIG:
foreach my $configN ( @$configs[1..$last_config] ) {
my $valN = $self->_normalize_value( # configN value
value => $configN->value_of($var),
is_directory => $is_dir,
base_path => $configN->value_of($base_path->{$var}) || "",
);
if ( $is_numeric->{$var} ) {
next CONFIG if $val0 == $valN;
}
else {
next CONFIG if $ignore_case
? lc($val0) eq lc($valN)
: $val0 eq $valN;
if ( $config0->format() ne $configN->format() ) {
if ( $any_value_is_true->{$var} ) {
next CONFIG if $val0 && $valN;
}
if ( $value_is_optional->{$var} ) {
next CONFIG if (!$val0 && $valN) || ($val0 && !$valN);
}
}
}
PTDEBUG && _d("Different", $var, "values:", $val0, $valN);
$diffs->{$var} = [ map { $_->value_of($var) } @$configs ];
last CONFIG;
} # CONFIG
};
if ( $EVAL_ERROR ) {
my $vals = join(', ',
map {
my $val = $_->value_of($var);
defined $val ? $val : 'undef'
} @$configs);
warn "Comparing $var values ($vals) caused an error: $EVAL_ERROR";
}
} # VARIABLE
return $diffs;
}
sub missing {
my ( $self, %args ) = @_;
my @required_args = qw(configs);
foreach my $arg( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($configs) = @args{@required_args};
if ( @$configs < 2 ) {
PTDEBUG && _d("Less than two MySQLConfig objects; nothing to compare");
return;
}
my %vars = map { $_ => 1 } map { keys %{$_->variables()} } @$configs;
my $missing;
foreach my $var ( keys %vars ) {
my $n_configs_having_var = grep { $_->has($var) } @$configs;
if ( $n_configs_having_var < @$configs ) {
$missing->{$var} = [ map { $_->has($var) ? 1 : 0 } @$configs ];
}
}
return $missing;
}
sub _normalize_value {
my ( $self, %args ) = @_;
my ($val, $is_dir, $base_path) = @args{qw(value is_directory base_path)};
$val = defined $val ? $val : '';
$val = $alt_val_for{$val} if exists $alt_val_for{$val};
if ( $val ) {
if ( $is_dir ) {
$val .= '/' unless $val =~ m/\/$/;
}
if ( $base_path && $val !~ m/^\// ) {
$val =~ s/^\.?(.+)/$base_path\/$1/; # prepend base path
$val =~ s/\/{2,}/\//g; # make redundant // single /
}
}
return $val;
}
sub _get_shared_vars {
my ( $self, %args ) = @_;
my ($configs) = @args{qw(configs)};
my $ignore_vars = $self->{ignore_vars};
my $config0 = $configs->[0];
my $last_config = @$configs - 1;
my @vars
= grep { !$ignore_vars->{$_} }
map {
my $config = $_;
my $vars = $config->variables();
grep { $config0->has($_); } keys %$vars;
} @$configs[1..$last_config];
return \@vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MySQLConfigComparer package
# ###########################################################################
# ###########################################################################
# ReportFormatter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/ReportFormatter.pm
# t/lib/ReportFormatter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package ReportFormatter;
use Lmo;
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(min max);
use POSIX qw(ceil);
eval { require Term::ReadKey };
my $have_term = $EVAL_ERROR ? 0 : 1;
has underline_header => (
is => 'ro',
isa => 'Bool',
default => sub { 1 },
);
has line_prefix => (
is => 'ro',
isa => 'Str',
default => sub { '# ' },
);
has line_width => (
is => 'ro',
isa => 'Int',
default => sub { 78 },
);
has column_spacing => (
is => 'ro',
isa => 'Str',
default => sub { ' ' },
);
has extend_right => (
is => 'ro',
isa => 'Bool',
default => sub { '' },
);
has truncate_line_mark => (
is => 'ro',
isa => 'Str',
default => sub { '...' },
);
has column_errors => (
is => 'ro',
isa => 'Str',
default => sub { 'warn' },
);
has truncate_header_side => (
is => 'ro',
isa => 'Str',
default => sub { 'left' },
);
has strip_whitespace => (
is => 'ro',
isa => 'Bool',
default => sub { 1 },
);
has title => (
is => 'rw',
isa => 'Str',
predicate => 'has_title',
);
has n_cols => (
is => 'rw',
isa => 'Int',
default => sub { 0 },
init_arg => undef,
);
has cols => (
is => 'ro',
isa => 'ArrayRef',
init_arg => undef,
default => sub { [] },
clearer => 'clear_cols',
);
has lines => (
is => 'ro',
isa => 'ArrayRef',
init_arg => undef,
default => sub { [] },
clearer => 'clear_lines',
);
has truncate_headers => (
is => 'rw',
isa => 'Bool',
default => sub { undef },
init_arg => undef,
clearer => 'clear_truncate_headers',
);
sub BUILDARGS {
my $class = shift;
my $args = $class->SUPER::BUILDARGS(@_);
if ( ($args->{line_width} || '') eq 'auto' ) {
die "Cannot auto-detect line width because the Term::ReadKey module "
. "is not installed" unless $have_term;
($args->{line_width}) = GetTerminalSize();
PTDEBUG && _d('Line width:', $args->{line_width});
}
return $args;
}
sub set_columns {
my ( $self, @cols ) = @_;
my $min_hdr_wid = 0; # check that header fits on line
my $used_width = 0;
my @auto_width_cols;
for my $i ( 0..$#cols ) {
my $col = $cols[$i];
my $col_name = $col->{name};
my $col_len = length $col_name;
die "Column does not have a name" unless defined $col_name;
if ( $col->{width} ) {
$col->{width_pct} = ceil(($col->{width} * 100) / $self->line_width());
PTDEBUG && _d('col:', $col_name, 'width:', $col->{width}, 'chars =',
$col->{width_pct}, '%');
}
if ( $col->{width_pct} ) {
$used_width += $col->{width_pct};
}
else {
PTDEBUG && _d('Auto width col:', $col_name);
$col->{auto_width} = 1;
push @auto_width_cols, $i;
}
$col->{truncate} = 1 unless defined $col->{truncate};
$col->{truncate_mark} = '...' unless defined $col->{truncate_mark};
$col->{truncate_side} ||= 'right';
$col->{undef_value} = '' unless defined $col->{undef_value};
$col->{min_val} = 0;
$col->{max_val} = 0;
$min_hdr_wid += $col_len;
$col->{header_width} = $col_len;
$col->{right_most} = 1 if $i == $#cols;
push @{$self->cols}, $col;
}
$self->n_cols( scalar @cols );
if ( ($used_width || 0) > 100 ) {
die "Total width_pct for all columns is >100%";
}
if ( @auto_width_cols ) {
my $wid_per_col = int((100 - $used_width) / scalar @auto_width_cols);
PTDEBUG && _d('Line width left:', (100-$used_width), '%;',
'each auto width col:', $wid_per_col, '%');
map { $self->cols->[$_]->{width_pct} = $wid_per_col } @auto_width_cols;
}
$min_hdr_wid += ($self->n_cols() - 1) * length $self->column_spacing();
PTDEBUG && _d('min header width:', $min_hdr_wid);
if ( $min_hdr_wid > $self->line_width() ) {
PTDEBUG && _d('Will truncate headers because min header width',
$min_hdr_wid, '> line width', $self->line_width());
$self->truncate_headers(1);
}
return;
}
sub add_line {
my ( $self, @vals ) = @_;
my $n_vals = scalar @vals;
if ( $n_vals != $self->n_cols() ) {
$self->_column_error("Number of values $n_vals does not match "
. "number of columns " . $self->n_cols());
}
for my $i ( 0..($n_vals-1) ) {
my $col = $self->cols->[$i];
my $val = defined $vals[$i] ? $vals[$i] : $col->{undef_value};
if ( $self->strip_whitespace() ) {
$val =~ s/^\s+//g;
$val =~ s/\s+$//;
$vals[$i] = $val;
}
my $width = length $val;
$col->{min_val} = min($width, ($col->{min_val} || $width));
$col->{max_val} = max($width, ($col->{max_val} || $width));
}
push @{$self->lines}, \@vals;
return;
}
sub get_report {
my ( $self, %args ) = @_;
$self->_calculate_column_widths();
if ( $self->truncate_headers() ) {
$self->_truncate_headers();
}
$self->_truncate_line_values(%args);
my @col_fmts = $self->_make_column_formats();
my $fmt = $self->line_prefix()
. join($self->column_spacing(), @col_fmts);
PTDEBUG && _d('Format:', $fmt);
(my $hdr_fmt = $fmt) =~ s/%([^-])/%-$1/g;
my @lines;
push @lines, $self->line_prefix() . $self->title() if $self->has_title();
push @lines, $self->_truncate_line(
sprintf($hdr_fmt, map { $_->{name} } @{$self->cols}),
strip => 1,
mark => '',
);
if ( $self->underline_header() ) {
my @underlines = map { '=' x $_->{print_width} } @{$self->cols};
push @lines, $self->_truncate_line(
sprintf($fmt, map { $_ || '' } @underlines),
mark => '',
);
}
push @lines, map {
my $vals = $_;
my $i = 0;
my @vals = map {
my $val = defined $_ ? $_ : $self->cols->[$i++]->{undef_value};
$val = '' if !defined $val;
$val =~ s/\n/ /g;
$val;
} @$vals;
my $line = sprintf($fmt, @vals);
if ( $self->extend_right() ) {
$line;
}
else {
$self->_truncate_line($line);
}
} @{$self->lines};
$self->clear_cols();
$self->clear_lines();
$self->clear_truncate_headers();
return join("\n", @lines) . "\n";
}
sub truncate_value {
my ( $self, $col, $val, $width, $side ) = @_;
return $val if length $val <= $width;
return $val if $col->{right_most} && $self->extend_right();
$side ||= $col->{truncate_side};
my $mark = $col->{truncate_mark};
if ( $side eq 'right' ) {
$val = substr($val, 0, $width - length $mark);
$val .= $mark;
}
elsif ( $side eq 'left') {
$val = $mark . substr($val, -1 * $width + length $mark);
}
else {
PTDEBUG && _d("I don't know how to", $side, "truncate values");
}
return $val;
}
sub _calculate_column_widths {
my ( $self ) = @_;
my $extra_space = 0;
foreach my $col ( @{$self->cols} ) {
my $print_width = int($self->line_width() * ($col->{width_pct} / 100));
PTDEBUG && _d('col:', $col->{name}, 'width pct:', $col->{width_pct},
'char width:', $print_width,
'min val:', $col->{min_val}, 'max val:', $col->{max_val});
if ( $col->{auto_width} ) {
if ( $col->{min_val} && $print_width < $col->{min_val} ) {
PTDEBUG && _d('Increased to min val width:', $col->{min_val});
$print_width = $col->{min_val};
}
elsif ( $col->{max_val} && $print_width > $col->{max_val} ) {
PTDEBUG && _d('Reduced to max val width:', $col->{max_val});
$extra_space += $print_width - $col->{max_val};
$print_width = $col->{max_val};
}
}
$col->{print_width} = $print_width;
PTDEBUG && _d('print width:', $col->{print_width});
}
PTDEBUG && _d('Extra space:', $extra_space);
while ( $extra_space-- ) {
foreach my $col ( @{$self->cols} ) {
if ( $col->{auto_width}
&& ( $col->{print_width} < $col->{max_val}
|| $col->{print_width} < $col->{header_width})
) {
$col->{print_width}++;
}
}
}
return;
}
sub _truncate_headers {
my ( $self, $col ) = @_;
my $side = $self->truncate_header_side();
foreach my $col ( @{$self->cols} ) {
my $col_name = $col->{name};
my $print_width = $col->{print_width};
next if length $col_name <= $print_width;
$col->{name} = $self->truncate_value($col, $col_name, $print_width, $side);
PTDEBUG && _d('Truncated hdr', $col_name, 'to', $col->{name},
'max width:', $print_width);
}
return;
}
sub _truncate_line_values {
my ( $self, %args ) = @_;
my $n_vals = $self->n_cols() - 1;
foreach my $vals ( @{$self->lines} ) {
for my $i ( 0..$n_vals ) {
my $col = $self->cols->[$i];
my $val = defined $vals->[$i] ? $vals->[$i] : $col->{undef_value};
my $width = length $val;
if ( $col->{print_width} && $width > $col->{print_width} ) {
if ( !$col->{truncate} ) {
$self->_column_error("Value '$val' is too wide for column "
. $col->{name});
}
my $callback = $args{truncate_callback};
my $print_width = $col->{print_width};
$val = $callback ? $callback->($col, $val, $print_width)
: $self->truncate_value($col, $val, $print_width);
PTDEBUG && _d('Truncated val', $vals->[$i], 'to', $val,
'; max width:', $print_width);
$vals->[$i] = $val;
}
}
}
return;
}
sub _make_column_formats {
my ( $self ) = @_;
my @col_fmts;
my $n_cols = $self->n_cols() - 1;
for my $i ( 0..$n_cols ) {
my $col = $self->cols->[$i];
my $width = $col->{right_most} && !$col->{right_justify} ? ''
: $col->{print_width};
my $col_fmt = '%' . ($col->{right_justify} ? '' : '-') . $width . 's';
push @col_fmts, $col_fmt;
}
return @col_fmts;
}
sub _truncate_line {
my ( $self, $line, %args ) = @_;
my $mark = defined $args{mark} ? $args{mark} : $self->truncate_line_mark();
if ( $line ) {
$line =~ s/\s+$// if $args{strip};
my $len = length($line);
if ( $len > $self->line_width() ) {
$line = substr($line, 0, $self->line_width() - length $mark);
$line .= $mark if $mark;
}
}
return $line;
}
sub _column_error {
my ( $self, $err ) = @_;
my $msg = "Column error: $err";
$self->column_errors() eq 'die' ? die $msg : warn $msg;
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
no Lmo;
1;
}
# ###########################################################################
# End ReportFormatter package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
{
my $file = 'percona-version-check';
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => md5_hex( hostname() ),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
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}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_config_diff;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub main {
local @ARGV = @_; # set global ARGV for this package
# ########################################################################
# Get configuration information.
# ########################################################################
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser();
$dp->prop('set-vars', $o->set_vars());
if ( !$o->get('help') ) {
if ( @ARGV < 1 ) {
$o->save_error("Specify at least one file or DSN on the command line");
}
}
$o->usage_or_errors();
# #########################################################################
# Make common modules.
# #########################################################################
my $trp = new TextResultSetParser();
my $config_cmp = new MySQLConfigComparer(
ignore_variables => $o->get('ignore-variables'),
ignore_case => $o->get('ignore-case'),
);
my %common_modules = (
DSNParser => $dp,
OptionParser => $o,
MySQLConfigComparer => $config_cmp,
TextResultSetParser => $trp,
);
# #########################################################################
# Make MySQLConfig objs for each FILE|DSN.
# #########################################################################
my $dsn_defaults = $dp->parse_options($o);
my $last_dsn;
my @configs; # MySQLConfig objects
my @config_names; # Human-readable names for those ^ objs
my @cxn;
foreach my $config_src ( @ARGV ) {
if ( -f $config_src ) {
PTDEBUG && _d('Config source', $config_src, 'is a file');
push @configs, new MySQLConfig(
file => $config_src,
%common_modules,
);
push @config_names, $config_src; # filename
}
else {
PTDEBUG && _d('Config source', $config_src, 'is a DSN');
my $cxn = new Cxn(
dsn_string => $config_src,
prev_dsn => $last_dsn,
DSNParser => $dp,
OptionParser => $o,
);
$cxn->connect();
$last_dsn = $cxn->dsn();
push @configs, new MySQLConfig(
dbh => $cxn->dbh(),
dsn => $cxn->dsn(),
%common_modules,
);
push @config_names, $cxn->name();
push @cxn, $cxn;
}
}
# ########################################################################
# Daemonize now that everything is setup and ready to work.
# ########################################################################
my $daemon;
if ( $o->get('pid') ) {
# We're not daemoninzing, it just handles PID stuff.
$daemon = new Daemon(o=>$o);
$daemon->make_PID_file();
}
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [ map({ +{ dbh => $_->dbh, dsn => $_->dsn } } @cxn) ],
);
}
# #########################################################################
# Diff the given configs.
# #########################################################################
my $report;
my $truncate_callback;
if ( $o->get('report') ) {
$report = new ReportFormatter(
line_prefix => '',
line_width => $o->get('report-width'),
);
$report->set_columns(
{ name => 'Variable', width=>25, },
map { { name => $_ } } @config_names,
);
# This is difficult. Ideally, we want to know which var this
# val applies to (i.e. first column, same row). But that's
# not how ReportFormatter works. Plus, even if we truncate a
# path on the left side, that might be where the difference is.
# So there's no easy solution here.
# $truncate_callback = sub {
# };
}
PTDEBUG && _d("Comparing", scalar @configs, "configs");
my $diffs = $config_cmp->diff(configs=>\@configs);
my $n_diffs = scalar keys %$diffs;
PTDEBUG && _d($n_diffs, "differences found:", Dumper($diffs));
if ( $n_diffs ) {
if ( $o->get('report') ) {
foreach my $var ( sort keys %$diffs ) {
$report->add_line($var, @{$diffs->{$var}});
}
$report->title(
"$n_diffs config difference" . ($n_diffs > 1 ? 's' : ''));
print $report->get_report();
}
return 1;
}
# No differences.
return 0;
}
# ##########################################################################
# Subroutines
# ##########################################################################
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation
# ############################################################################
=pod
=head1 NAME
pt-config-diff - Diff MySQL configuration files and server variables.
=head1 SYNOPSIS
Usage: pt-config-diff [OPTIONS] CONFIG CONFIG [CONFIG...]
pt-config-diff diffs MySQL configuration files and server variables.
CONFIG can be a filename or a DSN. At least two CONFIG sources must be given.
Like standard Unix diff, there is no output if there are no differences.
Diff host1 config from SHOW VARIABLES against host2:
pt-config-diff h=host1 h=host2
Diff config from [mysqld] section in my.cnf against host1 config:
pt-config-diff /etc/my.cnf h=host1
Diff the [mysqld] section of two option files:
pt-config-diff /etc/my-small.cnf /etc/my-large.cnf
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-config-diff diffs MySQL configurations by examining the values of server
system variables from two or more CONFIG sources specified on the command
line. A CONFIG source can be a DSN or a filename containing the output of
C, C, C, or
an option file (e.g. my.cnf).
For each DSN CONFIG, pt-config-diff connects to MySQL and gets variables
and values by executing C. This is
an "active config" because it shows what server values MySQL is
actively (currently) running with.
Only variables that all CONFIG sources have are compared because if a
variable is not present then we cannot know or safely guess its value.
For example, if you compare an option file (e.g. my.cnf) to an active config
(i.e. SHOW VARIABLES from a DSN CONFIG), the option file will probably
only have a few variables, whereas the active config has every variable.
Only values of the variables present in both configs are compared.
Option file and DSN configs provide the best results.
=head1 OUTPUT
There is no output when there are no differences. When there are differences,
pt-config-diff prints a report to STDOUT that looks similar to the following:
2 config differences
Variable my.master.cnf my.slave.cnf
========================= =============== ===============
datadir /tmp/12345/data /tmp/12346/data
port 12345 12346
Comparing MySQL variables is difficult because there are many variations and
subtleties across the many versions and distributions of MySQL. When a
comparison fails, the tool prints a warning to STDERR, such as the following:
Comparing log_error values (mysqld.log, /tmp/12345/data/mysqld.log)
caused an error: Argument "/tmp/12345/data/mysqld.log" isn't numeric
in numeric eq (==) at ./pt-config-diff line 2311.
Please report these warnings so the comparison functions can be improved.
=head1 EXIT STATUS
pt-config-diff exits with a zero exit status when there are no differences, and
1 if there are.
=head1 OPTIONS
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --charset
short form: -A; type: string
Default character set. If the value is utf8, sets Perl's binmode on
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and
runs SET NAMES UTF8 after connecting to MySQL. Any other value sets
binmode on STDOUT without the utf8 layer, and runs SET NAMES after
connecting to MySQL.
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line. (This option does not specify a CONFIG;
it's equivalent to C<--defaults-file>.)
=item --database
short form: -D; type: string
Connect to this database.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute
pathname.
=item --help
Show help and exit.
=item --host
short form: -h; type: string
Connect to host.
=item --[no]ignore-case
default: yes
Compare the variables case-insensitively.
=item --ignore-variables
type: array
Ignore, do not compare, these variables.
=item --password
short form: -p; type: string
Password to use for connection.
=item --pid
type: string
Create the given PID file. The tool won't start if the PID file already
exists and the PID it contains is different than the current PID. However,
if the PID file exists and the PID it contains is no longer running, the
tool will overwrite the PID file with the current PID. The PID file is
removed automatically when the tool exits.
=item --port
short form: -P; type: int
Port number to use for connection.
=item --[no]report
default: yes
Print the MySQL config diff report to STDOUT. If you just want to check
if the given configs are different or not by examining the tool's exit
status, then specify C<--no-report> to suppress the report.
=item --report-width
type: int; default: 78
Truncate report lines to this many characters. Since some variable values can
be long, or when comparing multiple configs, it may help to increase the
report width so values are not truncated beyond readability.
=item --set-vars
type: Array
Set the MySQL variables in this comma-separated list of C pairs.
By default, the tool sets:
=for comment ignore-pt-internal-value
MAGIC_set_vars
wait_timeout=10000
Variables specified on the command line override these defaults. For
example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
The tool prints a warning and continues if a variable cannot be set.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --user
short form: -u; type: string
MySQL user if not current user.
=item --version
Show version and exit.
=item --[no]version-check
default: yes
Check for the latest version of Percona Toolkit, MySQL, and other programs.
This is a standard "check for updates automatically" feature, with two
additional features. First, the tool checks the version of other programs
on the local system in addition to its own version. For example, it checks
the version of every MySQL server it connects to, Perl, and the Perl module
DBD::mysql. Second, it checks for and warns about versions with known
problems. For example, MySQL 5.5.25 had a critical bug and was re-released
as 5.5.25a.
Any updates or known problems are printed to STDOUT before the tool's normal
output. This feature should never interfere with the normal operation of the
tool.
For more information, visit L.
=back
=head1 DSN OPTIONS
These DSN options are used to create a DSN. Each option is given like
C. The options are case-sensitive, so P and p are not the
same option. There cannot be whitespace before or after the C<=> and
if the value contains whitespace it must be quoted. DSN options are
comma-separated. See the L manpage for full details.
=over
=item * A
dsn: charset; copy: yes
Default character set.
=item * D
dsn: database; copy: yes
Default database.
=item * F
dsn: mysql_read_default_file; copy: yes
Only read default options from the given file
=item * h
dsn: host; copy: yes
Connect to host.
=item * p
dsn: password; copy: yes
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item * P
dsn: port; copy: yes
Port number to use for connection.
=item * S
dsn: mysql_socket; copy: yes
Socket file to use for connection.
=item * u
dsn: user; copy: yes
User for login if not current user.
=back
=head1 ENVIRONMENT
The environment variable C enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-config-diff ... > FILE 2>&1
Be careful: debugging output is voluminous and can generate several megabytes
of output.
=head1 SYSTEM REQUIREMENTS
You need Perl, DBI, DBD::mysql, and some core packages that ought to be
installed in any reasonably new version of Perl.
=head1 BUGS
For a list of known bugs, see L.
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L with the name of any tool.
=head1 AUTHORS
Baron Schwartz and Daniel Nichter
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L "$tmpfile"
int main(void) {
int priority = getpriority(PRIO_PROCESS, $pid);
if ( priority == -1 && errno == ESRCH ) {
return 1;
}
else {
printf("%d\\n", priority);
return 0;
}
}
EOC
local c_comp=$(_which gcc)
if [ -z "${c_comp}" ]; then
c_comp=$(_which cc)
fi
_d "$tmpfile: $( cat "$tmpfile" )"
_d "$c_comp -xc \"$tmpfile\" -o \"$tmpfile\" && eval \"$tmpfile\""
$c_comp -xc "$tmpfile" -o "$tmpfile" 2>/dev/null && eval "$tmpfile" 2>/dev/null
if [ $? -ne 0 ]; then
echo "?"
_d "Failed to get a niceness value for $pid"
fi
fi
}
get_oom_of_pid () {
local pid="$1"
local oom_adj=""
if [ -n "${pid}" -a -e /proc/cpuinfo ]; then
if [ -s "/proc/$pid/oom_score_adj" ]; then
oom_adj=$(cat "/proc/$pid/oom_score_adj" 2>/dev/null)
_d "For $pid, the oom value is $oom_adj, retreived from oom_score_adj"
else
oom_adj=$(cat "/proc/$pid/oom_adj" 2>/dev/null)
_d "For $pid, the oom value is $oom_adj, retreived from oom_adj"
fi
fi
if [ -n "${oom_adj}" ]; then
echo "${oom_adj}"
else
echo "?"
_d "Can't find the oom value for $pid"
fi
}
has_symbols () {
local executable="$(_which "$1")"
local has_symbols=""
if [ "${CMD_FILE}" ] \
&& [ "$($CMD_FILE "${executable}" | grep 'not stripped' )" ]; then
has_symbols=1
elif [ "${CMD_NM}" ] \
|| [ "${CMD_OBJDMP}" ]; then
if [ "${CMD_NM}" ] \
&& [ !"$("${CMD_NM}" -- "${executable}" 2>&1 | grep 'File format not recognized' )" ]; then
if [ -z "$( $CMD_NM -- "${executable}" 2>&1 | grep ': no symbols' )" ]; then
has_symbols=1
fi
elif [ -z "$("${CMD_OBJDUMP}" -t -- "${executable}" | grep '^no symbols$' )" ]; then
has_symbols=1
fi
fi
if [ "${has_symbols}" ]; then
echo "Yes"
else
echo "No"
fi
}
setup_data_dir () {
local existing_dir="$1"
local data_dir=""
if [ -z "$existing_dir" ]; then
mkdir "$PT_TMPDIR/data" || die "Cannot mkdir $PT_TMPDIR/data"
data_dir="$PT_TMPDIR/data"
else
if [ ! -d "$existing_dir" ]; then
mkdir "$existing_dir" || die "Cannot mkdir $existing_dir"
elif [ "$( ls -A "$existing_dir" )" ]; then
die "--save-samples directory isn't empty, halting."
fi
touch "$existing_dir/test" || die "Cannot write to $existing_dir"
rm "$existing_dir/test" || die "Cannot rm $existing_dir/test"
data_dir="$existing_dir"
fi
echo "$data_dir"
}
get_var () {
local varname="$1"
local file="$2"
awk -v pattern="${varname}" '$1 == pattern { if (length($2)) { len = length($1); print substr($0, len+index(substr($0, len+1), $2)) } }' "${file}"
}
# ###########################################################################
# End summary_common package
# ###########################################################################
# ###########################################################################
# collect_mysql_info package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/bash/collect_mysql_info.sh
# t/lib/bash/collect_mysql_info.sh
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
CMD_MYSQL="${CMD_MYSQL:-""}"
CMD_MYSQLDUMP="${CMD_MYSQLDUMP:-""}"
collect_mysqld_instances () {
local variables_file="$1"
local pids="$(_pidof mysqld)"
if [ -n "$pids" ]; then
for pid in $pids; do
local nice="$( get_nice_of_pid $pid )"
local oom="$( get_oom_of_pid $pid )"
echo "internal::nice_of_$pid $nice" >> "$variables_file"
echo "internal::oom_of_$pid $oom" >> "$variables_file"
done
pids="$(echo $pids | sed -e 's/ /,/g')"
ps ww -p "$pids" 2>/dev/null
else
echo "mysqld doesn't appear to be running"
fi
}
find_my_cnf_file() {
local file="$1"
local port="${2:-""}"
local cnf_file=""
if [ "$port" ]; then
cnf_file="$(grep --max-count 1 "/mysqld.*--port=$port" "$file" \
| awk 'BEGIN{RS=" "; FS="=";} $1 ~ /--defaults-file/ { print $2; }')"
else
cnf_file="$(grep --max-count 1 '/mysqld' "$file" \
| awk 'BEGIN{RS=" "; FS="=";} $1 ~ /--defaults-file/ { print $2; }')"
fi
if [ -z "$cnf_file" ]; then
if [ -e "/etc/my.cnf" ]; then
cnf_file="/etc/my.cnf"
elif [ -e "/etc/mysql/my.cnf" ]; then
cnf_file="/etc/mysql/my.cnf"
elif [ -e "/var/db/mysql/my.cnf" ]; then
cnf_file="/var/db/mysql/my.cnf";
fi
fi
echo "$cnf_file"
}
collect_mysql_variables () {
$CMD_MYSQL $EXT_ARGV -ss -e 'SHOW /*!40100 GLOBAL*/ VARIABLES'
}
collect_mysql_status () {
$CMD_MYSQL $EXT_ARGV -ss -e 'SHOW /*!50000 GLOBAL*/ STATUS'
}
collect_mysql_databases () {
$CMD_MYSQL $EXT_ARGV -ss -e 'SHOW DATABASES' 2>/dev/null
}
collect_mysql_plugins () {
$CMD_MYSQL $EXT_ARGV -ss -e 'SHOW PLUGINS' 2>/dev/null
}
collect_mysql_slave_status () {
$CMD_MYSQL $EXT_ARGV -ssE -e 'SHOW SLAVE STATUS' 2>/dev/null
}
collect_mysql_innodb_status () {
$CMD_MYSQL $EXT_ARGV -ssE -e 'SHOW /*!50000 ENGINE*/ INNODB STATUS' 2>/dev/null
}
collect_mysql_processlist () {
$CMD_MYSQL $EXT_ARGV -ssE -e 'SHOW FULL PROCESSLIST' 2>/dev/null
}
collect_mysql_users () {
$CMD_MYSQL $EXT_ARGV -ss -e 'SELECT COUNT(*), SUM(user=""), SUM(password=""), SUM(password NOT LIKE "*%") FROM mysql.user' 2>/dev/null
}
collect_master_logs_status () {
local master_logs_file="$1"
local master_status_file="$2"
$CMD_MYSQL $EXT_ARGV -ss -e 'SHOW MASTER LOGS' > "$master_logs_file" 2>/dev/null
$CMD_MYSQL $EXT_ARGV -ss -e 'SHOW MASTER STATUS' > "$master_status_file" 2>/dev/null
}
collect_mysql_deferred_status () {
local status_file="$1"
collect_mysql_status > "$PT_TMPDIR/defer_gatherer"
join "$status_file" "$PT_TMPDIR/defer_gatherer"
}
collect_internal_vars () {
local mysqld_executables="${1:-""}"
local FNV_64=""
if $CMD_MYSQL $EXT_ARGV -e 'SELECT FNV_64("a")' >/dev/null 2>&1; then
FNV_64="Enabled";
else
FNV_64="Unknown";
fi
local now="$($CMD_MYSQL $EXT_ARGV -ss -e 'SELECT NOW()')"
local user="$($CMD_MYSQL $EXT_ARGV -ss -e 'SELECT CURRENT_USER()')"
local trigger_count=$($CMD_MYSQL $EXT_ARGV -ss -e "SELECT COUNT(*) FROM INFORMATION_SCHEMA.TRIGGERS" 2>/dev/null)
echo "pt-summary-internal-mysql_executable $CMD_MYSQL"
echo "pt-summary-internal-now $now"
echo "pt-summary-internal-user $user"
echo "pt-summary-internal-FNV_64 $FNV_64"
echo "pt-summary-internal-trigger_count $trigger_count"
if [ -e "$mysqld_executables" ]; then
local i=1
while read executable; do
echo "pt-summary-internal-mysqld_executable_${i} $(has_symbols "$executable")"
i=$(($i + 1))
done < "$mysqld_executables"
fi
}
get_mysqldump_for () {
local args="$1"
local dbtodump="${2:-"--all-databases"}"
$CMD_MYSQLDUMP $EXT_ARGV --no-data --skip-comments \
--skip-add-locks --skip-add-drop-table --compact \
--skip-lock-all-tables --skip-lock-tables --skip-set-charset \
${args} --databases $(local IFS=,; echo ${dbtodump})
}
get_mysqldump_args () {
local file="$1"
local trg_arg=""
if $CMD_MYSQLDUMP --help --verbose 2>&1 | grep triggers >/dev/null; then
trg_arg="--routines"
fi
if [ "${trg_arg}" ]; then
local triggers="--skip-triggers"
local trg=$(get_var "pt-summary-internal-trigger_count" "$file" )
if [ -n "${trg}" ] && [ "${trg}" -gt 0 ]; then
triggers="--triggers"
fi
trg_arg="${trg_arg} ${triggers}";
fi
echo "${trg_arg}"
}
collect_mysqld_executables () {
local mysqld_instances="$1"
local ps_opt="cmd="
if [ "$(uname -s)" = "Darwin" ]; then
ps_opt="command="
fi
for pid in $( grep '/mysqld' "$mysqld_instances" | awk '/^.*[0-9]/{print $1}' ); do
ps -o $ps_opt -p $pid | sed -e 's/^\(.*mysqld\) .*/\1/'
done | sort -u
}
collect_mysql_info () {
local dir="$1"
collect_mysql_variables > "$dir/mysql-variables"
collect_mysql_status > "$dir/mysql-status"
collect_mysql_databases > "$dir/mysql-databases"
collect_mysql_plugins > "$dir/mysql-plugins"
collect_mysql_slave_status > "$dir/mysql-slave"
collect_mysql_innodb_status > "$dir/innodb-status"
collect_mysql_processlist > "$dir/mysql-processlist"
collect_mysql_users > "$dir/mysql-users"
collect_mysqld_instances "$dir/mysql-variables" > "$dir/mysqld-instances"
collect_mysqld_executables "$dir/mysqld-instances" > "$dir/mysqld-executables"
local binlog="$(get_var log_bin "$dir/mysql-variables")"
if [ "${binlog}" ]; then
collect_master_logs_status "$dir/mysql-master-logs" "$dir/mysql-master-status"
fi
local uptime="$(get_var Uptime "$dir/mysql-status")"
local current_time="$($CMD_MYSQL $EXT_ARGV -ss -e \
"SELECT LEFT(NOW() - INTERVAL ${uptime} SECOND, 16)")"
local port="$(get_var port "$dir/mysql-variables")"
local cnf_file="$(find_my_cnf_file "$dir/mysqld-instances" ${port})"
[ -e "$cnf_file" ] && cat "$cnf_file" > "$dir/mysql-config-file"
local pid_file="$(get_var "pid_file" "$dir/mysql-variables")"
local pid_file_exists=""
[ -e "${pid_file}" ] && pid_file_exists=1
echo "pt-summary-internal-pid_file_exists $pid_file_exists" >> "$dir/mysql-variables"
echo "pt-summary-internal-current_time $current_time" >> "$dir/mysql-variables"
echo "pt-summary-internal-Config_File_path $cnf_file" >> "$dir/mysql-variables"
collect_internal_vars "$dir/mysqld-executables" >> "$dir/mysql-variables"
if [ "$OPT_DATABASES" -o "$OPT_ALL_DATABASES" ]; then
local trg_arg="$(get_mysqldump_args "$dir/mysql-variables")"
local dbs="${OPT_DATABASES:-""}"
get_mysqldump_for "${trg_arg}" "$dbs" > "$dir/mysqldump"
fi
(
sleep $OPT_SLEEP
collect_mysql_deferred_status "$dir/mysql-status" > "$dir/mysql-status-defer"
) &
_d "Forked child is $!"
}
# ###########################################################################
# End collect_mysql_info package
# ###########################################################################
# ###########################################################################
# report_mysql_info package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/bash/report_mysql_info.sh
# t/lib/bash/report_mysql_info.sh
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
set -u
POSIXLY_CORRECT=1
secs_to_time () {
awk -v sec="$1" 'BEGIN {
printf( "%d+%02d:%02d:%02d", sec / 86400, (sec % 86400) / 3600, (sec % 3600) / 60, sec % 60);
}'
}
feat_on() {
local file="$1"
local varname="$2"
[ -e "$file" ] || return
if [ "$( grep "$varname" "${file}" )" ]; then
local var="$(awk "\$1 ~ /^$2$/ { print \$2 }" $file)"
if [ "${var}" = "ON" ]; then
echo "Enabled"
elif [ "${var}" = "OFF" -o "${var}" = "0" -o -z "${var}" ]; then
echo "Disabled"
elif [ "${3:-""}" = "ne" ]; then
if [ "${var}" != "$4" ]; then
echo "Enabled"
else
echo "Disabled"
fi
elif [ "${3:-""}" = "gt" ]; then
if [ "${var}" -gt "$4" ]; then
echo "Enabled"
else
echo "Disabled"
fi
elif [ "${var}" ]; then
echo "Enabled"
else
echo "Disabled"
fi
else
echo "Not Supported"
fi
}
feat_on_renamed () {
local file="$1"
shift;
for varname in "$@"; do
local feat_on="$( feat_on "$file" $varname )"
if [ "${feat_on:-"Not Supported"}" != "Not Supported" ]; then
echo $feat_on
return
fi
done
echo "Not Supported"
}
get_table_cache () {
local file="$1"
[ -e "$file" ] || return
local table_cache=""
if [ "$( get_var table_open_cache "${file}" )" ]; then
table_cache="$(get_var table_open_cache "${file}")"
else
table_cache="$(get_var table_cache "${file}")"
fi
echo ${table_cache:-0}
}
get_plugin_status () {
local file="$1"
local plugin="$2"
local status="$(grep -w "$plugin" "$file" | awk '{ print $2 }')"
echo ${status:-"Not found"}
}
_NO_FALSE_NEGATIVES=""
parse_mysqld_instances () {
local file="$1"
local variables_file="$2"
local socket=""
local port=""
local datadir=""
local defaults_file=""
[ -e "$file" ] || return
echo " Port Data Directory Nice OOM Socket"
echo " ===== ========================== ==== === ======"
grep '/mysqld ' "$file" | while read line; do
local pid=$(echo "$line" | awk '{print $1;}')
for word in ${line}; do
if echo "${word}" | grep -- "--socket=" > /dev/null; then
socket="$(echo "${word}" | cut -d= -f2)"
fi
if echo "${word}" | grep -- "--port=" > /dev/null; then
port="$(echo "${word}" | cut -d= -f2)"
fi
if echo "${word}" | grep -- "--datadir=" > /dev/null; then
datadir="$(echo "${word}" | cut -d= -f2)"
fi
if echo "${word}" | grep -- "--defaults-file=" > /dev/null; then
defaults_file="$(echo "${word}" | cut -d= -f2)"
fi
done
if [ -n "${defaults_file:-""}" -a -r "${defaults_file:-""}" ]; then
socket="${socket:-"$(grep "^socket\>" "$defaults_file" | tail -n1 | cut -d= -f2 | sed 's/^[ \t]*//;s/[ \t]*$//')"}"
port="${port:-"$(grep "^port\>" "$defaults_file" | tail -n1 | cut -d= -f2 | sed 's/^[ \t]*//;s/[ \t]*$//')"}"
datadir="${datadir:-"$(grep "^datadir\>" "$defaults_file" | tail -n1 | cut -d= -f2 | sed 's/^[ \t]*//;s/[ \t]*$//')"}"
fi
local nice="$(get_var "internal::nice_of_$pid" "$variables_file")"
local oom="$(get_var "internal::oom_of_$pid" "$variables_file")"
if [ -n "${_NO_FALSE_NEGATIVES}" ]; then
nice="?"
oom="?"
fi
printf " %5s %-26s %-4s %-3s %s\n" "${port}" "${datadir}" "${nice:-"?"}" "${oom:-"?"}" "${socket}"
defaults_file=""
socket=""
port=""
datadir=""
done
}
get_mysql_timezone () {
local file="$1"
[ -e "$file" ] || return
local tz="$(get_var time_zone "${file}")"
if [ "${tz}" = "SYSTEM" ]; then
tz="$(get_var system_time_zone "${file}")"
fi
echo "${tz}"
}
get_mysql_version () {
local file="$1"
name_val Version "$(get_var version "${file}") $(get_var version_comment "${file}")"
name_val "Built On" "$(get_var version_compile_os "${file}") $(get_var version_compile_machine "${file}")"
}
get_mysql_uptime () {
local uptime="$1"
local restart="$2"
uptime="$(secs_to_time ${uptime})"
echo "${restart} (up ${uptime})"
}
summarize_binlogs () {
local file="$1"
[ -e "$file" ] || return
local size="$(awk '{t += $2} END{printf "%0.f\n", t}' "$file")"
name_val "Binlogs" $(wc -l "$file")
name_val "Zero-Sized" $(grep -c '\<0$' "$file")
name_val "Total Size" $(shorten ${size} 1)
}
format_users () {
local file="$1"
[ -e "$file" ] || return
awk '{printf "%d users, %d anon, %d w/o pw, %d old pw\n", $1, $2, $3, $4}' "${file}"
}
format_binlog_filters () {
local file="$1"
[ -e "$file" ] || return
name_val "binlog_do_db" "$(cut -f3 "$file")"
name_val "binlog_ignore_db" "$(cut -f4 "$file")"
}
format_status_variables () {
local file="$1"
[ -e "$file" ] || return
utime1="$(awk '/Uptime /{print $2}' "$file")";
utime2="$(awk '/Uptime /{print $3}' "$file")";
awk "
BEGIN {
utime1 = ${utime1};
utime2 = ${utime2};
udays = utime1 / 86400;
udiff = utime2 - utime1;
printf(\"%-35s %11s %11s %11s\\n\", \"Variable\", \"Per day\", \"Per second\", udiff \" secs\");
}
\$2 ~ /^[0-9]*\$/ {
if ( \$2 > 0 && \$2 < 18446744073709551615 ) {
if ( udays > 0 ) {
fuzzy_var=\$2 / udays;
${fuzzy_formula};
perday=fuzzy_var;
}
if ( utime1 > 0 ) {
fuzzy_var=\$2 / utime1;
${fuzzy_formula};
persec=fuzzy_var;
}
if ( udiff > 0 ) {
fuzzy_var=(\$3 - \$2) / udiff;
${fuzzy_formula};
nowsec=fuzzy_var;
}
perday = int(perday);
persec = int(persec);
nowsec = int(nowsec);
if ( perday + persec + nowsec > 0 ) {
perday_format=\"%11.f\";
persec_format=\"%11.f\";
nowsec_format=\"%11.f\";
if ( perday == 0 ) { perday = \"\"; perday_format=\"%11s\"; }
if ( persec == 0 ) { persec = \"\"; persec_format=\"%11s\"; }
if ( nowsec == 0 ) { nowsec = \"\"; nowsec_format=\"%11s\"; }
format=\"%-35s \" perday_format \" \" persec_format \" \" nowsec_format \"\\n\";
printf(format, \$1, perday, persec, nowsec);
}
}
}" "$file"
}
summarize_processlist () {
local file="$1"
[ -e "$file" ] || return
for param in Command User Host db State; do
echo
printf ' %-30s %8s %7s %9s %9s\n' \
"${param}" "COUNT(*)" Working "SUM(Time)" "MAX(Time)"
echo " ------------------------------" \
"-------- ------- --------- ---------"
cut -c1-80 "$file" \
| awk "
\$1 == \"${param}:\" {
p = substr(\$0, index(\$0, \":\") + 2);
if ( index(p, \":\") > 0 ) {
p = substr(p, 1, index(p, \":\") - 1);
}
if ( length(p) > 30 ) {
p = substr(p, 1, 30);
}
}
\$1 == \"Time:\" {
t = \$2;
}
\$1 == \"Command:\" {
c = \$2;
}
\$1 == \"Info:\" {
count[p]++;
if ( c == \"Sleep\" ) {
sleep[p]++;
}
if ( \"${param}\" == \"Command\" || c != \"Sleep\" ) {
time[p] += t;
if ( t > mtime[p] ) { mtime[p] = t; }
}
}
END {
for ( p in count ) {
fuzzy_var=count[p]-sleep[p]; ${fuzzy_formula} fuzzy_work=fuzzy_var;
fuzzy_var=count[p]; ${fuzzy_formula} fuzzy_count=fuzzy_var;
fuzzy_var=time[p]; ${fuzzy_formula} fuzzy_time=fuzzy_var;
fuzzy_var=mtime[p]; ${fuzzy_formula} fuzzy_mtime=fuzzy_var;
printf \" %-30s %8d %7d %9d %9d\n\", p, fuzzy_count, fuzzy_work, fuzzy_time, fuzzy_mtime;
}
}
" | sort
done
echo
}
pretty_print_cnf_file () {
local file="$1"
[ -e "$file" ] || return
perl -n -l -e '
my $line = $_;
if ( $line =~ /^[ \t]*[a-zA-Z[]/ ) {
if ( $line=~/\s*(.*?)\s*=\s*(.*)\s*$/ ) {
printf("%-35s = %s\n", $1, $2)
}
elsif ( $line =~ /\s*\[/ ) {
print "\n$line"
} else {
print $line
}
}' "$file"
}
find_checkpoint_age() {
local file="$1"
awk '
/Log sequence number/{
if ( $5 ) {
lsn = $5 + ($4 * 4294967296);
}
else {
lsn = $4;
}
}
/Last checkpoint at/{
if ( $5 ) {
print lsn - ($5 + ($4 * 4294967296));
}
else {
print lsn - $4;
}
}
' "$file"
}
find_pending_io_reads() {
local file="$1"
[ -e "$file" ] || return
awk '
/Pending normal aio reads/ {
normal_aio_reads = substr($5, 1, index($5, ","));
}
/ibuf aio reads/ {
ibuf_aio_reads = substr($4, 1, index($4, ","));
}
/pending preads/ {
preads = $1;
}
/Pending reads/ {
reads = $3;
}
END {
printf "%d buf pool reads, %d normal AIO", reads, normal_aio_reads;
printf ", %d ibuf AIO, %d preads", ibuf_aio_reads, preads;
}
' "${file}"
}
find_pending_io_writes() {
local file="$1"
[ -e "$file" ] || return
awk '
/aio writes/ {
aio_writes = substr($NF, 1, index($NF, ","));
}
/ibuf aio reads/ {
log_ios = substr($7, 1, index($7, ","));
sync_ios = substr($10, 1, index($10, ","));
}
/pending log writes/ {
log_writes = $1;
chkp_writes = $5;
}
/pending pwrites/ {
pwrites = $4;
}
/Pending writes:/ {
lru = substr($4, 1, index($4, ","));
flush_list = substr($7, 1, index($7, ","));
single_page = $NF;
}
END {
printf "%d buf pool (%d LRU, %d flush list, %d page); %d AIO, %d sync, %d log IO (%d log, %d chkp); %d pwrites", lru + flush_list + single_page, lru, flush_list, single_page, aio_writes, sync_ios, log_ios, log_writes, chkp_writes, pwrites;
}
' "${file}"
}
find_pending_io_flushes() {
local file="$1"
[ -e "$file" ] || return
awk '
/Pending flushes/ {
log_flushes = substr($5, 1, index($5, ";"));
buf_pool = $NF;
}
END {
printf "%d buf pool, %d log", buf_pool, log_flushes;
}
' "${file}"
}
summarize_undo_log_entries() {
local file="$1"
[ -e "$file" ] || return
grep 'undo log entries' "${file}" \
| sed -e 's/^.*undo log entries \([0-9]*\)/\1/' \
| awk '
{
count++;
sum += $1;
if ( $1 > max ) {
max = $1;
}
}
END {
printf "%d transactions, %d total undo, %d max undo\n", count, sum, max;
}'
}
find_max_trx_time() {
local file="$1"
[ -e "$file" ] || return
awk '
BEGIN {
max = 0;
}
/^---TRANSACTION.* sec,/ {
for ( i = 0; i < 7; ++i ) {
if ( $i == "sec," ) {
j = i-1;
if ( max < $j ) {
max = $j;
}
}
}
}
END {
print max;
}' "${file}"
}
find_transation_states () {
local file="$1"
local tmpfile="$PT_TMPDIR/find_transation_states.tmp"
[ -e "$file" ] || return
awk -F, '/^---TRANSACTION/{print $2}' "${file}" \
| sed -e 's/ [0-9]* sec.*//' \
| sort \
| uniq -c > "${tmpfile}"
group_concat "${tmpfile}"
}
format_innodb_status () {
local file=$1
[ -e "$file" ] || return
name_val "Checkpoint Age" "$(shorten $(find_checkpoint_age "${file}") 0)"
name_val "InnoDB Queue" "$(awk '/queries inside/{print}' "${file}")"
name_val "Oldest Transaction" "$(find_max_trx_time "${file}") Seconds";
name_val "History List Len" "$(awk '/History list length/{print $4}' "${file}")"
name_val "Read Views" "$(awk '/read views open inside/{print $1}' "${file}")"
name_val "Undo Log Entries" "$(summarize_undo_log_entries "${file}")"
name_val "Pending I/O Reads" "$(find_pending_io_reads "${file}")"
name_val "Pending I/O Writes" "$(find_pending_io_writes "${file}")"
name_val "Pending I/O Flushes" "$(find_pending_io_flushes "${file}")"
name_val "Transaction States" "$(find_transation_states "${file}" )"
if grep 'TABLE LOCK table' "${file}" >/dev/null ; then
echo "Tables Locked"
awk '/^TABLE LOCK table/{print $4}' "${file}" \
| sort | uniq -c | sort -rn
fi
if grep 'has waited at' "${file}" > /dev/null ; then
echo "Semaphore Waits"
grep 'has waited at' "${file}" | cut -d' ' -f6-8 \
| sort | uniq -c | sort -rn
fi
if grep 'reserved it in mode' "${file}" > /dev/null; then
echo "Semaphore Holders"
awk '/has reserved it in mode/{
print substr($0, 1 + index($0, "("), index($0, ")") - index($0, "(") - 1);
}' "${file}" | sort | uniq -c | sort -rn
fi
if grep -e 'Mutex at' -e 'lock on' "${file}" >/dev/null 2>&1; then
echo "Mutexes/Locks Waited For"
grep -e 'Mutex at' -e 'lock on' "${file}" | sed -e 's/^[XS]-//' -e 's/,.*$//' \
| sort | uniq -c | sort -rn
fi
}
format_overall_db_stats () {
local file="$1"
local tmpfile="$PT_TMPDIR/format_overall_db_stats.tmp"
[ -e "$file" ] || return
echo
awk '
BEGIN {
db = "{chosen}";
num_dbs = 0;
}
/^USE `.*`;$/ {
db = substr($2, 2, length($2) - 3);
if ( db_seen[db]++ == 0 ) {
dbs[num_dbs] = db;
num_dbs++;
}
}
/^CREATE TABLE/ {
if (num_dbs == 0) {
num_dbs = 1;
db_seen[db] = 1;
dbs[0] = db;
}
counts[db ",tables"]++;
}
/CREATE ALGORITHM=/ {
counts[db ",views"]++;
}
/03 CREATE.*03 PROCEDURE/ {
counts[db ",sps"]++;
}
/03 CREATE.*03 FUNCTION/ {
counts[db ",func"]++;
}
/03 CREATE.*03 TRIGGER/ {
counts[db ",trg"]++;
}
/FOREIGN KEY/ {
counts[db ",fk"]++;
}
/PARTITION BY/ {
counts[db ",partn"]++;
}
END {
mdb = length("Database");
for ( i = 0; i < num_dbs; i++ ) {
if ( length(dbs[i]) > mdb ) {
mdb = length(dbs[i]);
}
}
fmt = " %-" mdb "s %6s %5s %3s %5s %5s %5s %5s\n";
printf fmt, "Database", "Tables", "Views", "SPs", "Trigs", "Funcs", "FKs", "Partn";
for ( i=0;i "$tmpfile"
head -n2 "$tmpfile"
tail -n +3 "$tmpfile" | sort
echo
awk '
BEGIN {
db = "{chosen}";
num_dbs = 0;
num_engines = 0;
}
/^USE `.*`;$/ {
db = substr($2, 2, length($2) - 3);
if ( db_seen[db]++ == 0 ) {
dbs[num_dbs] = db;
num_dbs++;
}
}
/^\) ENGINE=/ {
if (num_dbs == 0) {
num_dbs = 1;
db_seen[db] = 1;
dbs[0] = db;
}
engine=substr($2, index($2, "=") + 1);
if ( engine_seen[tolower(engine)]++ == 0 ) {
engines[num_engines] = engine;
num_engines++;
}
counts[db "," engine]++;
}
END {
mdb = length("Database");
for ( i=0;i mdb ) {
mdb = length(db);
}
}
fmt = " %-" mdb "s"
printf fmt, "Database";
for ( i=0;i "$tmpfile"
head -n1 "$tmpfile"
tail -n +2 "$tmpfile" | sort
echo
awk '
BEGIN {
db = "{chosen}";
num_dbs = 0;
num_idxes = 0;
}
/^USE `.*`;$/ {
db = substr($2, 2, length($2) - 3);
if ( db_seen[db]++ == 0 ) {
dbs[num_dbs] = db;
num_dbs++;
}
}
/KEY/ {
if (num_dbs == 0) {
num_dbs = 1;
db_seen[db] = 1;
dbs[0] = db;
}
idx="BTREE";
if ( $0 ~ /SPATIAL/ ) {
idx="SPATIAL";
}
if ( $0 ~ /FULLTEXT/ ) {
idx="FULLTEXT";
}
if ( $0 ~ /USING RTREE/ ) {
idx="RTREE";
}
if ( $0 ~ /USING HASH/ ) {
idx="HASH";
}
if ( idx_seen[idx]++ == 0 ) {
idxes[num_idxes] = idx;
num_idxes++;
}
counts[db "," idx]++;
}
END {
mdb = length("Database");
for ( i=0;i mdb ) {
mdb = length(db);
}
}
fmt = " %-" mdb "s"
printf fmt, "Database";
for ( i=0;i "$tmpfile"
head -n1 "$tmpfile"
tail -n +2 "$tmpfile" | sort
echo
awk '
BEGIN {
db = "{chosen}";
num_dbs = 0;
num_types = 0;
}
/^USE `.*`;$/ {
db = substr($2, 2, length($2) - 3);
if ( db_seen[db]++ == 0 ) {
dbs[num_dbs] = db;
num_dbs++;
}
}
/^ `/ {
if (num_dbs == 0) {
num_dbs = 1;
db_seen[db] = 1;
dbs[0] = db;
}
str = $0;
str = substr(str, index(str, "`") + 1);
str = substr(str, index(str, "`") + 2);
if ( index(str, " ") > 0 ) {
str = substr(str, 1, index(str, " ") - 1);
}
if ( index(str, ",") > 0 ) {
str = substr(str, 1, index(str, ",") - 1);
}
if ( index(str, "(") > 0 ) {
str = substr(str, 1, index(str, "(") - 1);
}
type = str;
if ( type_seen[type]++ == 0 ) {
types[num_types] = type;
num_types++;
}
counts[db "," type]++;
}
END {
mdb = length("Database");
for ( i=0;i mdb ) {
mdb = length(db);
}
}
fmt = " %-" mdb "s"
mtlen = 0; # max type length
for ( i=0;i mtlen ) {
mtlen = length(type);
}
}
for ( i=1;i<=mtlen;i++ ) {
printf " %-" mdb "s", "";
for ( j=0;j length(type) ) {
ch = " ";
}
else {
ch = substr(type, i, 1);
}
printf(" %3s", ch);
}
print "";
}
printf " %-" mdb "s", "Database";
for ( i=0;i "$tmpfile"
local hdr=$(grep -n Database "$tmpfile" | cut -d: -f1);
head -n${hdr} "$tmpfile"
tail -n +$((${hdr} + 1)) "$tmpfile" | sort
echo
}
section_percona_server_features () {
local file="$1"
[ -e "$file" ] || return
name_val "Table & Index Stats" \
"$(feat_on_renamed "$file" userstat_running userstat)"
name_val "Multiple I/O Threads" \
"$(feat_on "$file" innodb_read_io_threads gt 1)"
name_val "Corruption Resilient" \
"$(feat_on_renamed "$file" innodb_pass_corrupt_table innodb_corrupt_table_action)"
name_val "Durable Replication" \
"$(feat_on_renamed "$file" innodb_overwrite_relay_log_info innodb_recovery_update_relay_log)"
name_val "Import InnoDB Tables" \
"$(feat_on_renamed "$file" innodb_expand_import innodb_import_table_from_xtrabackup)"
name_val "Fast Server Restarts" \
"$(feat_on_renamed "$file" innodb_auto_lru_dump innodb_buffer_pool_restore_at_startup)"
name_val "Enhanced Logging" \
"$(feat_on "$file" log_slow_verbosity ne microtime)"
name_val "Replica Perf Logging" \
"$(feat_on "$file" log_slow_slave_statements)"
name_val "Response Time Hist." \
"$(feat_on_renamed "$file" enable_query_response_time_stats query_response_time_stats)"
local smooth_flushing="$(feat_on_renamed "$file" innodb_adaptive_checkpoint innodb_adaptive_flushing_method)"
if [ "${smooth_flushing:-""}" != "Not Supported" ]; then
if [ -n "$(get_var innodb_adaptive_checkpoint "$file")" ]; then
smooth_flushing="$(feat_on "$file" "innodb_adaptive_checkpoint" ne none)"
else
smooth_flushing="$(feat_on "$file" "innodb_adaptive_flushing_method" ne native)"
fi
fi
name_val "Smooth Flushing" "$smooth_flushing"
name_val "HandlerSocket NoSQL" \
"$(feat_on "$file" handlersocket_port)"
name_val "Fast Hash UDFs" \
"$(get_var "pt-summary-internal-FNV_64" "$file")"
}
section_myisam () {
local variables_file="$1"
local status_file="$2"
[ -e "$variables_file" -a -e "$status_file" ] || return
local buf_size="$(get_var key_buffer_size "$variables_file")"
local blk_size="$(get_var key_cache_block_size "$variables_file")"
local blk_unus="$(get_var Key_blocks_unused "$status_file")"
local blk_unfl="$(get_var Key_blocks_not_flushed "$variables_file")"
local unus=$((${blk_unus:-0} * ${blk_size:-0}))
local unfl=$((${blk_unfl:-0} * ${blk_size:-0}))
local used=$((${buf_size:-0} - ${unus}))
name_val "Key Cache" "$(shorten ${buf_size} 1)"
name_val "Pct Used" "$(fuzzy_pct ${used} ${buf_size})"
name_val "Unflushed" "$(fuzzy_pct ${unfl} ${buf_size})"
}
section_innodb () {
local variables_file="$1"
local status_file="$2"
[ -e "$variables_file" -a -e "$status_file" ] || return
local version=$(get_var innodb_version "$variables_file")
name_val Version ${version:-default}
local bp_size="$(get_var innodb_buffer_pool_size "$variables_file")"
name_val "Buffer Pool Size" "$(shorten "${bp_size:-0}" 1)"
local bp_pags="$(get_var Innodb_buffer_pool_pages_total "$status_file")"
local bp_free="$(get_var Innodb_buffer_pool_pages_free "$status_file")"
local bp_dirt="$(get_var Innodb_buffer_pool_pages_dirty "$status_file")"
local bp_fill=$((${bp_pags} - ${bp_free}))
name_val "Buffer Pool Fill" "$(fuzzy_pct ${bp_fill} ${bp_pags})"
name_val "Buffer Pool Dirty" "$(fuzzy_pct ${bp_dirt} ${bp_pags})"
name_val "File Per Table" $(get_var innodb_file_per_table "$variables_file")
name_val "Page Size" $(shorten $(get_var Innodb_page_size "$status_file") 0)
local log_size="$(get_var innodb_log_file_size "$variables_file")"
local log_file="$(get_var innodb_log_files_in_group "$variables_file")"
local log_total=$(awk "BEGIN {printf \"%.2f\n\", ${log_size}*${log_file}}" )
name_val "Log File Size" \
"${log_file} * $(shorten ${log_size} 1) = $(shorten ${log_total} 1)"
name_val "Log Buffer Size" \
"$(shorten $(get_var innodb_log_buffer_size "$variables_file") 0)"
name_val "Flush Method" \
"$(get_var innodb_flush_method "$variables_file")"
name_val "Flush Log At Commit" \
"$(get_var innodb_flush_log_at_trx_commit "$variables_file")"
name_val "XA Support" \
"$(get_var innodb_support_xa "$variables_file")"
name_val "Checksums" \
"$(get_var innodb_checksums "$variables_file")"
name_val "Doublewrite" \
"$(get_var innodb_doublewrite "$variables_file")"
name_val "R/W I/O Threads" \
"$(get_var innodb_read_io_threads "$variables_file") $(get_var innodb_write_io_threads "$variables_file")"
name_val "I/O Capacity" \
"$(get_var innodb_io_capacity "$variables_file")"
name_val "Thread Concurrency" \
"$(get_var innodb_thread_concurrency "$variables_file")"
name_val "Concurrency Tickets" \
"$(get_var innodb_concurrency_tickets "$variables_file")"
name_val "Commit Concurrency" \
"$(get_var innodb_commit_concurrency "$variables_file")"
name_val "Txn Isolation Level" \
"$(get_var tx_isolation "$variables_file")"
name_val "Adaptive Flushing" \
"$(get_var innodb_adaptive_flushing "$variables_file")"
name_val "Adaptive Checkpoint" \
"$(get_var innodb_adaptive_checkpoint "$variables_file")"
}
section_noteworthy_variables () {
local file="$1"
[ -e "$file" ] || return
name_val "Auto-Inc Incr/Offset" "$(get_var auto_increment_increment "$file")/$(get_var auto_increment_offset "$file")"
for v in \
default_storage_engine flush_time init_connect init_file sql_mode;
do
name_val "${v}" "$(get_var ${v} "$file")"
done
for v in \
join_buffer_size sort_buffer_size read_buffer_size read_rnd_buffer_size \
bulk_insert_buffer max_heap_table_size tmp_table_size \
max_allowed_packet thread_stack;
do
name_val "${v}" "$(shorten $(get_var ${v} "$file") 0)"
done
for v in log log_error log_warnings log_slow_queries \
log_queries_not_using_indexes log_slave_updates;
do
name_val "${v}" "$(get_var ${v} "$file")"
done
}
_semi_sync_stats_for () {
local target="$1"
local file="$2"
[ -e "$file" ] || return
local semisync_status="$(get_var "Rpl_semi_sync_${target}_status" "${file}" )"
local semisync_trace="$(get_var "rpl_semi_sync_${target}_trace_level" "${file}")"
local trace_extra=""
if [ -n "${semisync_trace}" ]; then
if [ $semisync_trace -eq 1 ]; then
trace_extra="general (for example, time function failures) "
elif [ $semisync_trace -eq 16 ]; then
trace_extra="detail (more verbose information) "
elif [ $semisync_trace -eq 32 ]; then
trace_extra="net wait (more information about network waits)"
elif [ $semisync_trace -eq 64 ]; then
trace_extra="function (information about function entry and exit)"
else
trace_extra="Unknown setting"
fi
fi
name_val "${target} semisync status" "${semisync_status}"
name_val "${target} trace level" "${semisync_trace}, ${trace_extra}"
if [ "${target}" = "master" ]; then
name_val "${target} timeout in milliseconds" \
"$(get_var "rpl_semi_sync_${target}_timeout" "${file}")"
name_val "${target} waits for slaves" \
"$(get_var "rpl_semi_sync_${target}_wait_no_slave" "${file}")"
_d "Prepend Rpl_semi_sync_master_ to the following"
for v in \
clients net_avg_wait_time net_wait_time net_waits \
no_times no_tx timefunc_failures tx_avg_wait_time \
tx_wait_time tx_waits wait_pos_backtraverse \
wait_sessions yes_tx;
do
name_val "${target} ${v}" \
"$( get_var "Rpl_semi_sync_master_${v}" "${file}" )"
done
fi
}
noncounters_pattern () {
local noncounters_pattern=""
for var in Compression Delayed_insert_threads Innodb_buffer_pool_pages_data \
Innodb_buffer_pool_pages_dirty Innodb_buffer_pool_pages_free \
Innodb_buffer_pool_pages_latched Innodb_buffer_pool_pages_misc \
Innodb_buffer_pool_pages_total Innodb_data_pending_fsyncs \
Innodb_data_pending_reads Innodb_data_pending_writes \
Innodb_os_log_pending_fsyncs Innodb_os_log_pending_writes \
Innodb_page_size Innodb_row_lock_current_waits Innodb_row_lock_time_avg \
Innodb_row_lock_time_max Key_blocks_not_flushed Key_blocks_unused \
Key_blocks_used Last_query_cost Max_used_connections Ndb_cluster_node_id \
Ndb_config_from_host Ndb_config_from_port Ndb_number_of_data_nodes \
Not_flushed_delayed_rows Open_files Open_streams Open_tables \
Prepared_stmt_count Qcache_free_blocks Qcache_free_memory \
Qcache_queries_in_cache Qcache_total_blocks Rpl_status \
Slave_open_temp_tables Slave_running Ssl_cipher Ssl_cipher_list \
Ssl_ctx_verify_depth Ssl_ctx_verify_mode Ssl_default_timeout \
Ssl_session_cache_mode Ssl_session_cache_size Ssl_verify_depth \
Ssl_verify_mode Ssl_version Tc_log_max_pages_used Tc_log_page_size \
Threads_cached Threads_connected Threads_running \
Uptime_since_flush_status;
do
if [ -z "${noncounters_pattern}" ]; then
noncounters_pattern="${var}"
else
noncounters_pattern="${noncounters_pattern}\|${var}"
fi
done
echo $noncounters_pattern
}
section_mysqld () {
local executables_file="$1"
local variables_file="$2"
[ -e "$executables_file" -a -e "$variables_file" ] || return
section "MySQL Executable"
local i=1;
while read executable; do
name_val "Path to executable" "$executable"
name_val "Has symbols" "$( get_var "pt-summary-internal-mysqld_executable_${i}" "$variables_file" )"
i=$(($i + 1))
done < "$executables_file"
}
section_mysql_files () {
local variables_file="$1"
section "MySQL Files"
for file_name in pid_file slow_query_log_file general_log_file log_error; do
local file="$(get_var "${file_name}" "$variables_file")"
local name_out="$(echo "$file_name" | sed 'y/[a-z]/[A-Z]/')"
if [ -e "${file}" ]; then
name_val "$name_out" "$file"
name_val "${name_out} Size" "$(du "$file" | awk '{print $1}')"
else
name_val "$name_out" "(does not exist)"
fi
done
}
section_percona_xtradb_cluster () {
local mysql_var="$1"
local mysql_status="$2"
name_val "Cluster Name" "$(get_var "wsrep_cluster_name" "$mysql_var")"
name_val "Cluster Address" "$(get_var "wsrep_cluster_address" "$mysql_var")"
name_val "Cluster Size" "$(get_var "wsrep_cluster_size" "$mysql_status")"
name_val "Cluster Nodes" "$(get_var "wsrep_incoming_addresses" "$mysql_status")"
name_val "Node Name" "$(get_var "wsrep_node_name" "$mysql_var")"
name_val "Node Status" "$(get_var "wsrep_cluster_status" "$mysql_status")"
name_val "SST Method" "$(get_var "wsrep_sst_method" "$mysql_var")"
name_val "Slave Threads" "$(get_var "wsrep_slave_threads" "$mysql_var")"
name_val "Ignore Split Brain" "$( parse_wsrep_provider_options "pc.ignore_sb" "$mysql_var" )"
name_val "Ignore Quorum" "$( parse_wsrep_provider_options "pc.ignore_quorum" "$mysql_var" )"
name_val "gcache Size" "$( parse_wsrep_provider_options "gcache.size" "$mysql_var" )"
name_val "gcache Directory" "$( parse_wsrep_provider_options "gcache.dir" "$mysql_var" )"
name_val "gcache Name" "$( parse_wsrep_provider_options "gcache.name" "$mysql_var" )"
}
parse_wsrep_provider_options () {
local looking_for="$1"
local mysql_var_file="$2"
grep wsrep_provider_options "$mysql_var_file" \
| perl -Mstrict -le '
my $provider_opts = scalar();
my $looking_for = $ARGV[0];
my %opts = $provider_opts =~ /(\S+)\s*=\s*(\S*)(?:;|$)/g;
print $opts{$looking_for};
' "$looking_for"
}
report_mysql_summary () {
local dir="$1"
local NAME_VAL_LEN=25
section "Percona Toolkit MySQL Summary Report"
name_val "System time" "`date -u +'%F %T UTC'` (local TZ: `date +'%Z %z'`)"
section "Instances"
parse_mysqld_instances "$dir/mysqld-instances" "$dir/mysql-variables"
section_mysqld "$dir/mysqld-executables" "$dir/mysql-variables"
local user="$(get_var "pt-summary-internal-user" "$dir/mysql-variables")"
local port="$(get_var port "$dir/mysql-variables")"
local now="$(get_var "pt-summary-internal-now" "$dir/mysql-variables")"
section "Report On Port ${port}"
name_val User "${user}"
name_val Time "${now} ($(get_mysql_timezone "$dir/mysql-variables"))"
name_val Hostname "$(get_var hostname "$dir/mysql-variables")"
get_mysql_version "$dir/mysql-variables"
local uptime="$(get_var Uptime "$dir/mysql-status")"
local current_time="$(get_var "pt-summary-internal-current_time" "$dir/mysql-variables")"
name_val Started "$(get_mysql_uptime "${uptime}" "${current_time}")"
local num_dbs="$(grep -c . "$dir/mysql-databases")"
name_val Databases "${num_dbs}"
name_val Datadir "$(get_var datadir "$dir/mysql-variables")"
local fuzz_procs=$(fuzz $(get_var Threads_connected "$dir/mysql-status"))
local fuzz_procr=$(fuzz $(get_var Threads_running "$dir/mysql-status"))
name_val Processes "${fuzz_procs} connected, ${fuzz_procr} running"
local slave=""
if [ -s "$dir/mysql-slave" ]; then slave=""; else slave="not "; fi
local slavecount=$(grep -c 'Binlog Dump' "$dir/mysql-processlist")
name_val Replication "Is ${slave}a slave, has ${slavecount} slaves connected"
local pid_file="$(get_var "pid_file" "$dir/mysql-variables")"
local PID_EXISTS=""
if [ "$( get_var "pt-summary-internal-pid_file_exists" "$dir/mysql-variables" )" ]; then
PID_EXISTS="(exists)"
else
PID_EXISTS="(does not exist)"
fi
name_val Pidfile "${pid_file} ${PID_EXISTS}"
section "Processlist"
summarize_processlist "$dir/mysql-processlist"
section "Status Counters (Wait ${OPT_SLEEP} Seconds)"
wait
local noncounters_pattern="$(noncounters_pattern)"
format_status_variables "$dir/mysql-status-defer" | grep -v "${noncounters_pattern}"
section "Table cache"
local open_tables=$(get_var "Open_tables" "$dir/mysql-status")
local table_cache=$(get_table_cache "$dir/mysql-variables")
name_val Size $table_cache
name_val Usage "$(fuzzy_pct ${open_tables} ${table_cache})"
section "Key Percona Server features"
section_percona_server_features "$dir/mysql-variables"
section "Percona XtraDB Cluster"
local has_wsrep="$(get_var "wsrep_on" "$dir/mysql-variables")"
if [ -n "${has_wsrep:-""}" ]; then
local wsrep_on="$(feat_on "$dir/mysql-variables" "wsrep_on")"
if [ "${wsrep_on:-""}" = "Enabled" ]; then
section_percona_xtradb_cluster "$dir/mysql-variables" "$dir/mysql-status"
else
name_val "wsrep_on" "OFF"
fi
fi
section "Plugins"
name_val "InnoDB compression" "$(get_plugin_status "$dir/mysql-plugins" "INNODB_CMP")"
if [ "$(get_var have_query_cache "$dir/mysql-variables")" ]; then
section "Query cache"
local query_cache_size=$(get_var query_cache_size "$dir/mysql-variables")
local used=$(( ${query_cache_size} - $(get_var Qcache_free_memory "$dir/mysql-status") ))
local hrat=$(fuzzy_pct $(get_var Qcache_hits "$dir/mysql-status") $(get_var Qcache_inserts "$dir/mysql-status"))
name_val query_cache_type $(get_var query_cache_type "$dir/mysql-variables")
name_val Size "$(shorten ${query_cache_size} 1)"
name_val Usage "$(fuzzy_pct ${used} ${query_cache_size})"
name_val HitToInsertRatio "${hrat}"
fi
local semisync_enabled_master="$(get_var "rpl_semi_sync_master_enabled" "$dir/mysql-variables")"
if [ -n "${semisync_enabled_master}" ]; then
section "Semisynchronous Replication"
if [ "$semisync_enabled_master" = "OFF" -o "$semisync_enabled_master" = "0" -o -z "$semisync_enabled_master" ]; then
name_val "Master" "Disabled"
else
_semi_sync_stats_for "master" "$dir/mysql-variables"
fi
local semisync_enabled_slave="$(get_var rpl_semi_sync_slave_enabled "$dir/mysql-variables")"
if [ "$semisync_enabled_slave" = "OFF" -o "$semisync_enabled_slave" = "0" -o -z "$semisync_enabled_slave" ]; then
name_val "Slave" "Disabled"
else
_semi_sync_stats_for "slave" "$dir/mysql-variables"
fi
fi
section "Schema"
if [ -s "$dir/mysqldump" ] \
&& grep 'CREATE TABLE' "$dir/mysqldump" >/dev/null 2>&1; then
format_overall_db_stats "$dir/mysqldump"
elif [ ! -e "$dir/mysqldump" -a "$OPT_READ_SAMPLES" ]; then
echo "Skipping schema analysis because --read-samples $dir/mysqldump " \
"does not exist"
elif [ -z "$OPT_DATABASES" -a -z "$OPT_ALL_DATABASES" ]; then
echo "Specify --databases or --all-databases to dump and summarize schemas"
else
echo "Skipping schema analysis due to apparent error in dump file"
fi
section "Noteworthy Technologies"
if [ -s "$dir/mysqldump" ]; then
if grep FULLTEXT "$dir/mysqldump" > /dev/null; then
name_val "Full Text Indexing" "Yes"
else
name_val "Full Text Indexing" "No"
fi
if grep 'GEOMETRY\|POINT\|LINESTRING\|POLYGON' "$dir/mysqldump" > /dev/null; then
name_val "Geospatial Types" "Yes"
else
name_val "Geospatial Types" "No"
fi
if grep 'FOREIGN KEY' "$dir/mysqldump" > /dev/null; then
name_val "Foreign Keys" "Yes"
else
name_val "Foreign Keys" "No"
fi
if grep 'PARTITION BY' "$dir/mysqldump" > /dev/null; then
name_val "Partitioning" "Yes"
else
name_val "Partitioning" "No"
fi
if grep -e 'ENGINE=InnoDB.*ROW_FORMAT' \
-e 'ENGINE=InnoDB.*KEY_BLOCK_SIZE' "$dir/mysqldump" > /dev/null; then
name_val "InnoDB Compression" "Yes"
else
name_val "InnoDB Compression" "No"
fi
fi
local ssl="$(get_var Ssl_accepts "$dir/mysql-status")"
if [ -n "$ssl" -a "${ssl:-0}" -gt 0 ]; then
name_val "SSL" "Yes"
else
name_val "SSL" "No"
fi
local lock_tables="$(get_var Com_lock_tables "$dir/mysql-status")"
if [ -n "$lock_tables" -a "${lock_tables:-0}" -gt 0 ]; then
name_val "Explicit LOCK TABLES" "Yes"
else
name_val "Explicit LOCK TABLES" "No"
fi
local delayed_insert="$(get_var Delayed_writes "$dir/mysql-status")"
if [ -n "$delayed_insert" -a "${delayed_insert:-0}" -gt 0 ]; then
name_val "Delayed Insert" "Yes"
else
name_val "Delayed Insert" "No"
fi
local xat="$(get_var Com_xa_start "$dir/mysql-status")"
if [ -n "$xat" -a "${xat:-0}" -gt 0 ]; then
name_val "XA Transactions" "Yes"
else
name_val "XA Transactions" "No"
fi
local ndb_cluster="$(get_var "Ndb_cluster_node_id" "$dir/mysql-status")"
if [ -n "$ndb_cluster" -a "${ndb_cluster:-0}" -gt 0 ]; then
name_val "NDB Cluster" "Yes"
else
name_val "NDB Cluster" "No"
fi
local prep=$(( $(get_var "Com_stmt_prepare" "$dir/mysql-status") + $(get_var "Com_prepare_sql" "$dir/mysql-status") ))
if [ "${prep}" -gt 0 ]; then
name_val "Prepared Statements" "Yes"
else
name_val "Prepared Statements" "No"
fi
local prep_count="$(get_var Prepared_stmt_count "$dir/mysql-status")"
if [ "${prep_count}" ]; then
name_val "Prepared statement count" "${prep_count}"
fi
section "InnoDB"
local have_innodb="$(get_var "have_innodb" "$dir/mysql-variables")"
local innodb_version="$(get_var "innodb_version" "$dir/mysql-variables")"
if [ "${have_innodb}" = "YES" ] || [ -n "${innodb_version}" ]; then
section_innodb "$dir/mysql-variables" "$dir/mysql-status"
if [ -s "$dir/innodb-status" ]; then
format_innodb_status "$dir/innodb-status"
fi
fi
section "MyISAM"
section_myisam "$dir/mysql-variables" "$dir/mysql-status"
section "Security"
local users="$( format_users "$dir/mysql-users" )"
name_val "Users" "${users}"
name_val "Old Passwords" "$(get_var old_passwords "$dir/mysql-variables")"
section "Binary Logging"
if [ -s "$dir/mysql-master-logs" ] \
|| [ -s "$dir/mysql-master-status" ]; then
summarize_binlogs "$dir/mysql-master-logs"
local format="$(get_var binlog_format "$dir/mysql-variables")"
name_val binlog_format "${format:-STATEMENT}"
name_val expire_logs_days "$(get_var expire_logs_days "$dir/mysql-variables")"
name_val sync_binlog "$(get_var sync_binlog "$dir/mysql-variables")"
name_val server_id "$(get_var server_id "$dir/mysql-variables")"
format_binlog_filters "$dir/mysql-master-status"
fi
section "Noteworthy Variables"
section_noteworthy_variables "$dir/mysql-variables"
section "Configuration File"
local cnf_file="$(get_var "pt-summary-internal-Config_File_path" "$dir/mysql-variables")"
if [ -n "${cnf_file}" ]; then
name_val "Config File" "${cnf_file}"
pretty_print_cnf_file "$dir/mysql-config-file"
else
name_val "Config File" "Cannot autodetect or find, giving up"
fi
section "The End"
}
# ###########################################################################
# End report_mysql_info package
# ###########################################################################
# ########################################################################
# Some global setup is necessary for cross-platform compatibility, even
# when sourcing this script for testing purposes.
# ########################################################################
TOOL="pt-mysql-summary"
# These vars are declared earlier in the collect_mysql_info package,
# but if they're still undefined here, try to find them in PATH.
[ "$CMD_MYSQL" ] || CMD_MYSQL="$(_which mysql)"
[ "$CMD_MYSQLDUMP" ] || CMD_MYSQLDUMP="$( _which mysqldump )"
check_mysql () {
# Check that mysql and mysqldump are in PATH. If not, we're
# already dead in the water, so don't bother with cmd line opts,
# just error and exit.
[ -n "$(mysql --help 2>/dev/null)" ] \
|| die "Cannot execute mysql. Check that it is in PATH."
[ -n "$(mysqldump --help 2>/dev/null)" ] \
|| die "Cannot execute mysqldump. Check that it is in PATH."
# Now that we have the cmd line opts, check that we can actually
# connect to MySQL.
[ -n "$(mysql $EXT_ARGV -e 'SHOW STATUS')" ] \
|| die "Cannot connect to MySQL. Check that MySQL is running and that the options after -- are correct."
}
sigtrap() {
warn "Caught signal, forcing exit"
rm_tmpdir
exit $EXIT_STATUS
}
# ##############################################################################
# The main() function is called at the end of the script. This makes it
# testable. Major bits of parsing are separated into functions for testability.
# ##############################################################################
main() {
# Prepending SIG to these doesn't work with NetBSD's sh
trap sigtrap HUP INT TERM
local MYSQL_ARGS="$(mysql_options)"
EXT_ARGV="$(arrange_mysql_options "$EXT_ARGV $MYSQL_ARGS")"
# Check if mysql and mysqldump are there, otherwise bail out early.
# But don't if they passed in --read-samples, since we don't need
# a connection then.
[ "$OPT_READ_SAMPLES" ] || check_mysql
local RAN_WITH="--sleep=$OPT_SLEEP --databases=$OPT_DATABASES --save-samples=$OPT_SAVE_SAMPLES"
_d "Starting $0 $RAN_WITH"
# Begin by setting the $PATH to include some common locations that are not
# always in the $PATH, including the "sbin" locations. On SunOS systems,
# prefix the path with the location of more sophisticated utilities.
export PATH="${PATH}:/usr/local/bin:/usr/bin:/bin:/usr/libexec"
export PATH="${PATH}:/usr/mysql/bin/:/usr/local/sbin:/usr/sbin:/sbin"
export PATH="/usr/gnu/bin/:/usr/xpg4/bin/:${PATH}"
_d "Going to use: mysql=${CMD_MYSQL} mysqldump=${CMD_MYSQLDUMP}"
# Create the tmpdir for everything to run in
mk_tmpdir
# Set DATA_DIR where we'll save collected data files.
local data_dir="$(setup_data_dir "${OPT_SAVE_SAMPLES:-""}")"
if [ -z "$data_dir" ]; then
exit $?
fi
if [ -n "$OPT_READ_SAMPLES" -a -d "$OPT_READ_SAMPLES" ]; then
# --read-samples was set and is a directory, so the samples
# will already be there.
data_dir="$OPT_READ_SAMPLES"
else
# #####################################################################
# Fetch most info, leave a child in the background gathering the rest
# #####################################################################
collect_mysql_info "${data_dir}" 2>"${data_dir}/collect.err"
fi
# ########################################################################
# Format and pretty-print the data
# ########################################################################
report_mysql_summary "${data_dir}"
rm_tmpdir
}
# Execute the program if it was not included from another file.
# This makes it possible to include without executing, and thus test.
if [ "${0##*/}" = "$TOOL" ] \
|| [ "${0##*/}" = "bash" -a "${_:-""}" = "$0" ]; then
# Set up temporary dir.
mk_tmpdir
# Parse command line options.
parse_options "$0" "${@:-""}"
# Verify that --sleep, if present, is positive
if [ -n "$OPT_SLEEP" ] && [ "$OPT_SLEEP" -lt 0 ]; then
option_error "Invalid --sleep value: $sleep"
fi
usage_or_errors "$0"
po_status=$?
rm_tmpdir
if [ $po_status -ne 0 ]; then
[ $OPT_ERRS -gt 0 ] && exit 1
exit 0
fi
main "${@:-""}"
fi
# ############################################################################
# Documentation
# ############################################################################
:<<'DOCUMENTATION'
=pod
=head1 NAME
pt-mysql-summary - Summarize MySQL information nicely.
=head1 SYNOPSIS
Usage: pt-mysql-summary [OPTIONS]
pt-mysql-summary conveniently summarizes the status and configuration of a
MySQL database server so that you can learn about it at a glance. It is not
a tuning tool or diagnosis tool. It produces a report that is easy to diff
and can be pasted into emails without losing the formatting. It should work
well on any modern UNIX systems.
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-mysql-summary works by connecting to a MySQL database server and querying
it for status and configuration information. It saves these bits of data
into files in a temporary directory, and then formats them neatly with awk
and other scripting languages.
To use, simply execute it. Optionally add a double dash and then the same
command-line options you would use to connect to MySQL, such as the following:
pt-mysql-summary --user=root
The tool interacts minimally with the server upon which it runs. It assumes
that you'll run it on the same server you're inspecting, and therefore it
assumes that it will be able to find the my.cnf configuration file, for example.
However, it should degrade gracefully if this is not the case. Note, however,
that its output does not indicate which information comes from the MySQL
database and which comes from the host operating system, so it is possible for
confusing output to be generated if you run the tool on one server and connect
to a MySQL database server running on another server.
=head1 OUTPUT
Many of the outputs from this tool are deliberately rounded to show their
magnitude but not the exact detail. This is called fuzzy-rounding. The idea
is that it does not matter whether a server is running 918 queries per second
or 921 queries per second; such a small variation is insignificant, and only
makes the output hard to compare to other servers. Fuzzy-rounding rounds in
larger increments as the input grows. It begins by rounding to the nearest 5,
then the nearest 10, nearest 25, and then repeats by a factor of 10 larger
(50, 100, 250), and so on, as the input grows.
The following is a sample of the report that the tool produces:
# Percona Toolkit MySQL Summary Report #######################
System time | 2012-03-30 18:46:05 UTC
(local TZ: EDT -0400)
# Instances ##################################################
Port Data Directory Nice OOM Socket
===== ========================== ==== === ======
12345 /tmp/12345/data 0 0 /tmp/12345.sock
12346 /tmp/12346/data 0 0 /tmp/12346.sock
12347 /tmp/12347/data 0 0 /tmp/12347.sock
The first two sections show which server the report was generated on and which
MySQL instances are running on the server. This is detected from the output of
C and does not always detect all instances and parameters, but often works
well. From this point forward, the report will be focused on a single MySQL
instance, although several instances may appear in the above paragraph.
# Report On Port 12345 #######################################
User | msandbox@%
Time | 2012-03-30 14:46:05 (EDT)
Hostname | localhost.localdomain
Version | 5.5.20-log MySQL Community Server (GPL)
Built On | linux2.6 i686
Started | 2012-03-28 23:33 (up 1+15:12:09)
Databases | 4
Datadir | /tmp/12345/data/
Processes | 2 connected, 2 running
Replication | Is not a slave, has 1 slaves connected
Pidfile | /tmp/12345/data/12345.pid (exists)
This section is a quick summary of the MySQL instance: version, uptime, and
other very basic parameters. The Time output is generated from the MySQL server,
unlike the system date and time printed earlier, so you can see whether the
database and operating system times match.
# Processlist ################################################
Command COUNT(*) Working SUM(Time) MAX(Time)
------------------------------ -------- ------- --------- ---------
Binlog Dump 1 1 150000 150000
Query 1 1 0 0
User COUNT(*) Working SUM(Time) MAX(Time)
------------------------------ -------- ------- --------- ---------
msandbox 2 2 150000 150000
Host COUNT(*) Working SUM(Time) MAX(Time)
------------------------------ -------- ------- --------- ---------
localhost 2 2 150000 150000
db COUNT(*) Working SUM(Time) MAX(Time)
------------------------------ -------- ------- --------- ---------
NULL 2 2 150000 150000
State COUNT(*) Working SUM(Time) MAX(Time)
------------------------------ -------- ------- --------- ---------
Master has sent all binlog to 1 1 150000 150000
NULL 1 1 0 0
This section is a summary of the output from SHOW PROCESSLIST. Each sub-section
is aggregated by a different item, which is shown as the first column heading.
When summarized by Command, every row in SHOW PROCESSLIST is included, but
otherwise, rows whose Command is Sleep are excluded from the SUM and MAX
columns, so they do not skew the numbers too much. In the example shown, the
server is idle except for this tool itself, and one connected replica, which
is executing Binlog Dump.
The columns are the number of rows included, the number that are not in Sleep
status, the sum of the Time column, and the maximum Time column. The numbers are
fuzzy-rounded.
# Status Counters (Wait 10 Seconds) ##########################
Variable Per day Per second 10 secs
Binlog_cache_disk_use 4
Binlog_cache_use 80
Bytes_received 15000000 175 200
Bytes_sent 15000000 175 2000
Com_admin_commands 1
...................(many lines omitted)............................
Threads_created 40 1
Uptime 90000 1 1
This section shows selected counters from two snapshots of SHOW GLOBAL STATUS,
gathered approximately 10 seconds apart and fuzzy-rounded. It includes only
items that are incrementing counters; it does not include absolute numbers such
as the Threads_running status variable, which represents a current value, rather
than an accumulated number over time.
The first column is the variable name, and the second column is the counter from
the first snapshot divided by 86400 (the number of seconds in a day), so you can
see the magnitude of the counter's change per day. 86400 fuzzy-rounds to 90000,
so the Uptime counter should always be about 90000.
The third column is the value from the first snapshot, divided by Uptime and
then fuzzy-rounded, so it represents approximately how quickly the counter is
growing per-second over the uptime of the server.
The third column is the incremental difference from the first and second
snapshot, divided by the difference in uptime and then fuzzy-rounded. Therefore,
it shows how quickly the counter is growing per second at the time the report
was generated.
# Table cache ################################################
Size | 400
Usage | 15%
This section shows the size of the table cache, followed by the percentage of
the table cache in use. The usage is fuzzy-rounded.
# Key Percona Server features ################################
Table & Index Stats | Not Supported
Multiple I/O Threads | Enabled
Corruption Resilient | Not Supported
Durable Replication | Not Supported
Import InnoDB Tables | Not Supported
Fast Server Restarts | Not Supported
Enhanced Logging | Not Supported
Replica Perf Logging | Not Supported
Response Time Hist. | Not Supported
Smooth Flushing | Not Supported
HandlerSocket NoSQL | Not Supported
Fast Hash UDFs | Unknown
This section shows features that are available in Percona Server and whether
they are enabled or not. In the example shown, the server is standard MySQL, not
Percona Server, so the features are generally not supported.
# Plugins ####################################################
InnoDB compression | ACTIVE
This feature shows specific plugins and whether they are enabled.
# Query cache ################################################
query_cache_type | ON
Size | 0.0
Usage | 0%
HitToInsertRatio | 0%
This section shows whether the query cache is enabled and its size, followed by
the percentage of the cache in use and the hit-to-insert ratio. The latter two
are fuzzy-rounded.
# Schema #####################################################
Database Tables Views SPs Trigs Funcs FKs Partn
mysql 24
performance_schema 17
sakila 16 7 3 6 3 22
Database MyISAM CSV PERFORMANCE_SCHEMA InnoDB
mysql 22 2
performance_schema 17
sakila 8 15
Database BTREE FULLTEXT
mysql 31
performance_schema
sakila 63 1
c t s e l d i t m v s
h i e n o a n i e a m
a m t u n t t n d r a
r e m g e y i c l
s b t i u h l
t l i n m a i
a o m t t r n
m b e e t
p x
t
Database === === === === === === === === === === ===
mysql 61 10 6 78 5 4 26 3 4 5 3
performance_schema 5 16 33
sakila 1 15 1 3 4 3 19 42 26
If you specify L<"--databases"> or L<"--all-databases">, the tool will print
the above section. This summarizes the number and type of objects in the
databases. It is generated by running C, not by querying
the INFORMATION_SCHEMA, which can freeze a busy server.
The first sub-report in the section is the count of objects by type in each
database: tables, views, and so on. The second one shows how many tables use
various storage engines in each database. The third sub-report shows the number
of each type of indexes in each database.
The last section shows the number of columns of various data types in each
database. For compact display, the column headers are formatted vertically, so
you need to read downwards from the top. In this example, the first column is
C and the second column is C. This example is truncated so it
does not wrap on a terminal.
All of the numbers in this portion of the output are exact, not fuzzy-rounded.
# Noteworthy Technologies ####################################
Full Text Indexing | Yes
Geospatial Types | No
Foreign Keys | Yes
Partitioning | No
InnoDB Compression | Yes
SSL | No
Explicit LOCK TABLES | No
Delayed Insert | No
XA Transactions | No
NDB Cluster | No
Prepared Statements | No
Prepared statement count | 0
This section shows some specific technologies used on this server. Some of them
are detected from the schema dump performed for the previous sections; others
can be detected by looking at SHOW GLOBAL STATUS.
# InnoDB #####################################################
Version | 1.1.8
Buffer Pool Size | 16.0M
Buffer Pool Fill | 100%
Buffer Pool Dirty | 0%
File Per Table | OFF
Page Size | 16k
Log File Size | 2 * 5.0M = 10.0M
Log Buffer Size | 8M
Flush Method |
Flush Log At Commit | 1
XA Support | ON
Checksums | ON
Doublewrite | ON
R/W I/O Threads | 4 4
I/O Capacity | 200
Thread Concurrency | 0
Concurrency Tickets | 500
Commit Concurrency | 0
Txn Isolation Level | REPEATABLE-READ
Adaptive Flushing | ON
Adaptive Checkpoint |
Checkpoint Age | 0
InnoDB Queue | 0 queries inside InnoDB, 0 queries in queue
Oldest Transaction | 0 Seconds
History List Len | 209
Read Views | 1
Undo Log Entries | 1 transactions, 1 total undo, 1 max undo
Pending I/O Reads | 0 buf pool reads, 0 normal AIO,
0 ibuf AIO, 0 preads
Pending I/O Writes | 0 buf pool (0 LRU, 0 flush list, 0 page);
0 AIO, 0 sync, 0 log IO (0 log, 0 chkp);
0 pwrites
Pending I/O Flushes | 0 buf pool, 0 log
Transaction States | 1xnot started
This section shows important configuration variables for the InnoDB storage
engine. The buffer pool fill percent and dirty percent are fuzzy-rounded. The
last few lines are derived from the output of SHOW INNODB STATUS. It is likely
that this output will change in the future to become more useful.
# MyISAM #####################################################
Key Cache | 16.0M
Pct Used | 10%
Unflushed | 0%
This section shows the size of the MyISAM key cache, followed by the percentage
of the cache in use and percentage unflushed (fuzzy-rounded).
# Security ###################################################
Users | 2 users, 0 anon, 0 w/o pw, 0 old pw
Old Passwords | OFF
This section is generated from queries to tables in the mysql system database.
It shows how many users exist, and various potential security risks such as
old-style passwords and users without passwords.
# Binary Logging #############################################
Binlogs | 1
Zero-Sized | 0
Total Size | 21.8M
binlog_format | STATEMENT
expire_logs_days | 0
sync_binlog | 0
server_id | 12345
binlog_do_db |
binlog_ignore_db |
This section shows configuration and status of the binary logs. If there are
zero-sized binary logs, then it is possible that the binlog index is out of sync
with the binary logs that actually exist on disk.
# Noteworthy Variables #######################################
Auto-Inc Incr/Offset | 1/1
default_storage_engine | InnoDB
flush_time | 0
init_connect |
init_file |
sql_mode |
join_buffer_size | 128k
sort_buffer_size | 2M
read_buffer_size | 128k
read_rnd_buffer_size | 256k
bulk_insert_buffer | 0.00
max_heap_table_size | 16M
tmp_table_size | 16M
max_allowed_packet | 1M
thread_stack | 192k
log | OFF
log_error | /tmp/12345/data/mysqld.log
log_warnings | 1
log_slow_queries | ON
log_queries_not_using_indexes | OFF
log_slave_updates | ON
This section shows several noteworthy server configuration variables that might
be important to know about when working with this server.
# Configuration File #########################################
Config File | /tmp/12345/my.sandbox.cnf
[client]
user = msandbox
password = msandbox
port = 12345
socket = /tmp/12345/mysql_sandbox12345.sock
[mysqld]
port = 12345
socket = /tmp/12345/mysql_sandbox12345.sock
pid-file = /tmp/12345/data/mysql_sandbox12345.pid
basedir = /home/baron/5.5.20
datadir = /tmp/12345/data
key_buffer_size = 16M
innodb_buffer_pool_size = 16M
innodb_data_home_dir = /tmp/12345/data
innodb_log_group_home_dir = /tmp/12345/data
innodb_data_file_path = ibdata1:10M:autoextend
innodb_log_file_size = 5M
log-bin = mysql-bin
relay_log = mysql-relay-bin
log_slave_updates
server-id = 12345
report-host = 127.0.0.1
report-port = 12345
log-error = mysqld.log
innodb_lock_wait_timeout = 3
# The End ####################################################
This section shows a pretty-printed version of the my.cnf file, with comments
removed and with whitespace added to align things for easy reading. The tool
tries to detect the my.cnf file by looking at the output of ps, and if it does
not find the location of the file there, it tries common locations until it
finds a file. Note that this file might not actually correspond with the server
from which the report was generated. This can happen when the tool isn't run on
the same server it's reporting on, or when detecting the location of the
configuration file fails.
=head1 OPTIONS
All options after -- are passed to C.
=over
=item --all-databases
mysqldump and summarize all databases. See L<"--databases">.
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --config
type: string
Read this comma-separated list of config files. If specified, this must be the
first option on the command line.
=item --databases
type: string
mysqldump and summarize this comma-separated list of databases. Specify
L<"--all-databases"> instead if you want to dump and summary all databases.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute
pathname.
=item --help
Print help and exit.
=item --host
short form: -h; type: string
Host to connect to.
=item --password
short form: -p; type: string
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item --port
short form: -P; type: int
Port number to use for connection.
=item --read-samples
type: string
Create a report from the files found in this directory.
=item --save-samples
type: string
Save the data files used to generate the summary in this directory.
=item --sleep
type: int; default: 10
Seconds to sleep when gathering status counters.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --user
short form: -u; type: string
User for login if not current user.
=item --version
Print tool's version and exit.
=back
=head1 ENVIRONMENT
This tool does not use any environment variables.
=head1 SYSTEM REQUIREMENTS
This tool requires Bash v3 or newer, Perl 5.8 or newer, and binutils.
These are generally already provided by most distributions.
On BSD systems, it may require a mounted procfs.
=head1 BUGS
For a list of known bugs, see L.
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L with the name of any tool.
=head1 AUTHORS
Baron Schwartz, Brian Fraser, and Daniel Nichter
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L.
It can create and summarize full stack traces of processes on Linux.
Summaries of stack traces can be an invaluable tool for diagnosing what
a process is waiting for.
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-pmp performs two tasks: it gets a stack trace, and it summarizes the stack
trace. If a file is given on the command line, the tool skips the first step
and just aggregates the file.
To summarize the stack trace, the tool extracts the function name (symbol)
from each level of the stack, and combines them with commas. It does this
for each thread in the output. Afterwards, it sorts similar threads together
and counts how many of each one there are, then sorts them most-frequent first.
pt-pmp is a read-only tool. However, collecting GDB stacktraces is achieved by
attaching GDB to the program and printing stack traces from all threads. This
will freeze the program for some period of time, ranging from a second or so to
much longer on very busy systems with a lot of memory and many threads in the
program. In the tool's default usage as a MySQL profiling tool, this means that
MySQL will be unresponsive while the tool runs, although if you are using the
tool to diagnose an unresponsive server, there is really no reason not to do
this. In addition to freezing the server, there is also some risk of the server
crashing or performing badly after GDB detaches from it.
=head1 OPTIONS
=over
=item --binary
short form: -b; type: string; default: mysqld
Which binary to trace.
=item --help
Show help and exit.
=item --interval
short form: -s; type: int; default: 0
Number of seconds to sleep between L<"--iterations">.
=item --iterations
short form: -i; type: int; default: 1
How many traces to gather and aggregate.
=item --lines
short form: -l; type: int; default: 0
Aggregate only first specified number of many functions; 0=infinity.
=item --pid
short form: -p; type: int
Process ID of the process to trace; overrides L<"--binary">.
=item --save-samples
short form: -k; type: string
Keep the raw traces in this file after aggregation.
=item --version
Show version and exit.
=back
=head1 ENVIRONMENT
This tool does not use any environment variables.
=head1 SYSTEM REQUIREMENTS
This tool requires Bash v3 or newer. If no backtrace files are given,
then gdb is also required to create backtraces for the process specified
on the command line.
=head1 BUGS
For a list of known bugs, see L.
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L with the name of any tool.
=head1 AUTHORS
Baron Schwartz, based on a script by Domas Mituzas (L);
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# Lmo::Utils package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Utils.pm
# t/lib/Lmo/Utils.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Utils;
use strict;
use warnings qw( FATAL all );
require Exporter;
our (@ISA, @EXPORT, @EXPORT_OK);
BEGIN {
@ISA = qw(Exporter);
@EXPORT = @EXPORT_OK = qw(
_install_coderef
_unimport_coderefs
_glob_for
_stash_for
);
}
{
no strict 'refs';
sub _glob_for {
return \*{shift()}
}
sub _stash_for {
return \%{ shift() . "::" };
}
}
sub _install_coderef {
my ($to, $code) = @_;
return *{ _glob_for $to } = $code;
}
sub _unimport_coderefs {
my ($target, @names) = @_;
return unless @names;
my $stash = _stash_for($target);
foreach my $name (@names) {
if ($stash->{$name} and defined(&{$stash->{$name}})) {
delete $stash->{$name};
}
}
}
1;
}
# ###########################################################################
# End Lmo::Utils package
# ###########################################################################
# ###########################################################################
# Lmo::Meta package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Meta.pm
# t/lib/Lmo/Meta.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Meta;
use strict;
use warnings qw( FATAL all );
my %metadata_for;
sub new {
my $class = shift;
return bless { @_ }, $class
}
sub metadata_for {
my $self = shift;
my ($class) = @_;
return $metadata_for{$class} ||= {};
}
sub class { shift->{class} }
sub attributes {
my $self = shift;
return keys %{$self->metadata_for($self->class)}
}
sub attributes_for_new {
my $self = shift;
my @attributes;
my $class_metadata = $self->metadata_for($self->class);
while ( my ($attr, $meta) = each %$class_metadata ) {
if ( exists $meta->{init_arg} ) {
push @attributes, $meta->{init_arg}
if defined $meta->{init_arg};
}
else {
push @attributes, $attr;
}
}
return @attributes;
}
1;
}
# ###########################################################################
# End Lmo::Meta package
# ###########################################################################
# ###########################################################################
# Lmo::Object package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Object.pm
# t/lib/Lmo/Object.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Object;
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(blessed);
use Lmo::Meta;
use Lmo::Utils qw(_glob_for);
sub new {
my $class = shift;
my $args = $class->BUILDARGS(@_);
my $class_metadata = Lmo::Meta->metadata_for($class);
my @args_to_delete;
while ( my ($attr, $meta) = each %$class_metadata ) {
next unless exists $meta->{init_arg};
my $init_arg = $meta->{init_arg};
if ( defined $init_arg ) {
$args->{$attr} = delete $args->{$init_arg};
}
else {
push @args_to_delete, $attr;
}
}
delete $args->{$_} for @args_to_delete;
for my $attribute ( keys %$args ) {
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
$args->{$attribute} = $coerce->($args->{$attribute});
}
if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
my ($check_name, $check_sub) = @$isa_check;
$check_sub->($args->{$attribute});
}
}
while ( my ($attribute, $meta) = each %$class_metadata ) {
next unless $meta->{required};
Carp::confess("Attribute ($attribute) is required for $class")
if ! exists $args->{$attribute}
}
my $self = bless $args, $class;
my @build_subs;
my $linearized_isa = mro::get_linear_isa($class);
for my $isa_class ( @$linearized_isa ) {
unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
}
my @args = %$args;
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
$sub->( $self, @args);
}
return $self;
}
sub BUILDARGS {
shift; # No need for the classname
if ( @_ == 1 && ref($_[0]) ) {
Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
unless ref($_[0]) eq ref({});
return {%{$_[0]}} # We want a new reference, always
}
else {
return { @_ };
}
}
sub meta {
my $class = shift;
$class = Scalar::Util::blessed($class) || $class;
return Lmo::Meta->new(class => $class);
}
1;
}
# ###########################################################################
# End Lmo::Object package
# ###########################################################################
# ###########################################################################
# Lmo::Types package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Types.pm
# t/lib/Lmo/Types.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Types;
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
our %TYPES = (
Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
Num => sub { defined $_[0] && looks_like_number($_[0]) },
Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
Str => sub { defined $_[0] },
Object => sub { defined $_[0] && blessed($_[0]) },
FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
map {
my $type = /R/ ? $_ : uc $_;
$_ . "Ref" => sub { ref $_[0] eq $type }
} qw(Array Code Hash Regexp Glob Scalar)
);
sub check_type_constaints {
my ($attribute, $type_check, $check_name, $val) = @_;
( ref($type_check) eq 'CODE'
? $type_check->($val)
: (ref $val eq $type_check
|| ($val && $val eq $type_check)
|| (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
)
|| Carp::confess(
qq
. qq
. (defined $val ? Lmo::Dumper($val) : 'undef') )
}
sub _nested_constraints {
my ($attribute, $aggregate_type, $type) = @_;
my $inner_types;
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$inner_types = _nested_constraints($1, $2);
}
else {
$inner_types = $TYPES{$type};
}
if ( $aggregate_type eq 'ArrayRef' ) {
return sub {
my ($val) = @_;
return unless ref($val) eq ref([]);
if ($inner_types) {
for my $value ( @{$val} ) {
return unless $inner_types->($value)
}
}
else {
for my $value ( @{$val} ) {
return unless $value && ($value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type)));
}
}
return 1;
};
}
elsif ( $aggregate_type eq 'Maybe' ) {
return sub {
my ($value) = @_;
return 1 if ! defined($value);
if ($inner_types) {
return unless $inner_types->($value)
}
else {
return unless $value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type));
}
return 1;
}
}
else {
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
}
}
1;
}
# ###########################################################################
# End Lmo::Types package
# ###########################################################################
# ###########################################################################
# Lmo package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo.pm
# t/lib/Lmo.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
BEGIN {
$INC{"Lmo.pm"} = __FILE__;
package Lmo;
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
use Lmo::Meta;
use Lmo::Object;
use Lmo::Types;
use Lmo::Utils;
my %export_for;
sub import {
warnings->import(qw(FATAL all));
strict->import();
my $caller = scalar caller(); # Caller's package
my %exports = (
extends => \&extends,
has => \&has,
with => \&with,
override => \&override,
confess => \&Carp::confess,
);
$export_for{$caller} = \%exports;
for my $keyword ( keys %exports ) {
_install_coderef "${caller}::$keyword" => $exports{$keyword};
}
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
@_ = "Lmo::Object";
goto *{ _glob_for "${caller}::extends" }{CODE};
}
}
sub extends {
my $caller = scalar caller();
for my $class ( @_ ) {
_load_module($class);
}
_set_package_isa($caller, @_);
_set_inherited_metadata($caller);
}
sub _load_module {
my ($class) = @_;
(my $file = $class) =~ s{::|'}{/}g;
$file .= '.pm';
{ local $@; eval { require "$file" } } # or warn $@;
return;
}
sub with {
my $package = scalar caller();
require Role::Tiny;
for my $role ( @_ ) {
_load_module($role);
_role_attribute_metadata($package, $role);
}
Role::Tiny->apply_roles_to_package($package, @_);
}
sub _role_attribute_metadata {
my ($package, $role) = @_;
my $package_meta = Lmo::Meta->metadata_for($package);
my $role_meta = Lmo::Meta->metadata_for($role);
%$package_meta = (%$role_meta, %$package_meta);
}
sub has {
my $names = shift;
my $caller = scalar caller();
my $class_metadata = Lmo::Meta->metadata_for($caller);
for my $attribute ( ref $names ? @$names : $names ) {
my %args = @_;
my $method = ($args{is} || '') eq 'ro'
? sub {
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
if $#_;
return $_[0]{$attribute};
}
: sub {
return $#_
? $_[0]{$attribute} = $_[1]
: $_[0]{$attribute};
};
$class_metadata->{$attribute} = ();
if ( my $type_check = $args{isa} ) {
my $check_name = $type_check;
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
}
my $check_sub = sub {
my ($new_val) = @_;
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
};
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
my $orig_method = $method;
$method = sub {
$check_sub->($_[1]) if $#_;
goto &$orig_method;
};
}
if ( my $builder = $args{builder} ) {
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$builder
: goto &$original_method
};
}
if ( my $code = $args{default} ) {
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
unless ref($code) eq 'CODE';
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$code
: goto &$original_method
};
}
if ( my $role = $args{does} ) {
my $original_method = $method;
$method = sub {
if ( $#_ ) {
Carp::confess(qq)
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
}
goto &$original_method
};
}
if ( my $coercion = $args{coerce} ) {
$class_metadata->{$attribute}{coerce} = $coercion;
my $original_method = $method;
$method = sub {
if ( $#_ ) {
return $original_method->($_[0], $coercion->($_[1]))
}
goto &$original_method;
}
}
_install_coderef "${caller}::$attribute" => $method;
if ( $args{required} ) {
$class_metadata->{$attribute}{required} = 1;
}
if ($args{clearer}) {
_install_coderef "${caller}::$args{clearer}"
=> sub { delete shift->{$attribute} }
}
if ($args{predicate}) {
_install_coderef "${caller}::$args{predicate}"
=> sub { exists shift->{$attribute} }
}
if ($args{handles}) {
_has_handles($caller, $attribute, \%args);
}
if (exists $args{init_arg}) {
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
}
}
}
sub _has_handles {
my ($caller, $attribute, $args) = @_;
my $handles = $args->{handles};
my $ref = ref $handles;
my $kv;
if ( $ref eq ref [] ) {
$kv = { map { $_,$_ } @{$handles} };
}
elsif ( $ref eq ref {} ) {
$kv = $handles;
}
elsif ( $ref eq ref qr// ) {
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
unless $args->{isa};
my $target_class = $args->{isa};
$kv = {
map { $_, $_ }
grep { $_ =~ $handles }
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
grep { !$export_for{$target_class}->{$_} }
keys %{ _stash_for $target_class }
};
}
else {
Carp::confess("handles for $ref not yet implemented");
}
while ( my ($method, $target) = each %{$kv} ) {
my $name = _glob_for "${caller}::$method";
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
if defined &$name;
my ($target, @curried_args) = ref($target) ? @$target : $target;
*$name = sub {
my $self = shift;
my $delegate_to = $self->$attribute();
my $error = "Cannot delegate $method to $target because the value of $attribute";
Carp::confess("$error is not defined") unless $delegate_to;
Carp::confess("$error is not an object (got '$delegate_to')")
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
return $delegate_to->$target(@curried_args, @_);
}
}
}
sub _set_package_isa {
my ($package, @new_isa) = @_;
my $package_isa = \*{ _glob_for "${package}::ISA" };
@{*$package_isa} = @new_isa;
}
sub _set_inherited_metadata {
my $class = shift;
my $class_metadata = Lmo::Meta->metadata_for($class);
my $linearized_isa = mro::get_linear_isa($class);
my %new_metadata;
for my $isa_class (reverse @$linearized_isa) {
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
%new_metadata = (
%new_metadata,
%$isa_metadata,
);
}
%$class_metadata = %new_metadata;
}
sub unimport {
my $caller = scalar caller();
my $target = caller;
_unimport_coderefs($target, keys %{$export_for{$caller}});
}
sub Dumper {
require Data::Dumper;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Sortkeys = 0;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_)
}
BEGIN {
if ($] >= 5.010) {
{ local $@; require mro; }
}
else {
local $@;
eval {
require MRO::Compat;
} or do {
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
no strict 'refs';
my $classname = shift;
my @lin = ($classname);
my %stored;
foreach my $parent (@{"$classname\::ISA"}) {
my $plin = mro::get_linear_isa_dfs($parent);
foreach (@$plin) {
next if exists $stored{$_};
push(@lin, $_);
$stored{$_} = 1;
}
}
return \@lin;
};
}
}
}
sub override {
my ($methods, $code) = @_;
my $caller = scalar caller;
for my $method ( ref($methods) ? @$methods : $methods ) {
my $full_method = "${caller}::${method}";
*{_glob_for $full_method} = $code;
}
}
}
1;
}
# ###########################################################################
# End Lmo package
# ###########################################################################
# ###########################################################################
# VersionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionParser.pm
# t/lib/VersionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionParser;
use Lmo;
use Scalar::Util qw(blessed);
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use overload (
'""' => "version",
'<=>' => "cmp",
'cmp' => "cmp",
fallback => 1,
);
use Carp ();
our $VERSION = 0.01;
has major => (
is => 'ro',
isa => 'Int',
required => 1,
);
has [qw( minor revision )] => (
is => 'ro',
isa => 'Num',
);
has flavor => (
is => 'ro',
isa => 'Str',
default => sub { 'Unknown' },
);
has innodb_version => (
is => 'ro',
isa => 'Str',
default => sub { 'NO' },
);
sub series {
my $self = shift;
return $self->_join_version($self->major, $self->minor);
}
sub version {
my $self = shift;
return $self->_join_version($self->major, $self->minor, $self->revision);
}
sub is_in {
my ($self, $target) = @_;
return $self eq $target;
}
sub _join_version {
my ($self, @parts) = @_;
return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
}
sub _split_version {
my ($self, $str) = @_;
my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
return @version_parts[0..2];
}
sub normalized_version {
my ( $self ) = @_;
my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
$self->minor,
$self->revision);
PTDEBUG && _d($self->version, 'normalizes to', $result);
return $result;
}
sub comment {
my ( $self, $cmd ) = @_;
my $v = $self->normalized_version();
return "/*!$v $cmd */"
}
my @methods = qw(major minor revision);
sub cmp {
my ($left, $right) = @_;
my $right_obj = (blessed($right) && $right->isa(ref($left)))
? $right
: ref($left)->new($right);
my $retval = 0;
for my $m ( @methods ) {
last unless defined($left->$m) && defined($right_obj->$m);
$retval = $left->$m <=> $right_obj->$m;
last if $retval;
}
return $retval;
}
sub BUILDARGS {
my $self = shift;
if ( @_ == 1 ) {
my %args;
if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
my $dbh = $_[0];
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $query = eval {
$dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
};
if ( $query ) {
$query = { map { $_->{variable_name} => $_->{value} } @$query };
@args{@methods} = $self->_split_version($query->{version});
$args{flavor} = delete $query->{version_comment}
if $query->{version_comment};
}
elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
@args{@methods} = $self->_split_version($query);
}
else {
Carp::confess("Couldn't get the version from the dbh while "
. "creating a VersionParser object: $@");
}
$args{innodb_version} = eval { $self->_innodb_version($dbh) };
}
elsif ( !ref($_[0]) ) {
@args{@methods} = $self->_split_version($_[0]);
}
for my $method (@methods) {
delete $args{$method} unless defined $args{$method};
}
@_ = %args if %args;
}
return $self->SUPER::BUILDARGS(@_);
}
sub _innodb_version {
my ( $self, $dbh ) = @_;
return unless $dbh;
my $innodb_version = "NO";
my ($innodb) =
grep { $_->{engine} =~ m/InnoDB/i }
map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
if ( $innodb ) {
PTDEBUG && _d("InnoDB support:", $innodb->{support});
if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
my $vars = $dbh->selectrow_hashref(
"SHOW VARIABLES LIKE 'innodb_version'");
$innodb_version = !$vars ? "BUILTIN"
: ($vars->{Value} || $vars->{value});
}
else {
$innodb_version = $innodb->{support}; # probably DISABLED or NO
}
}
PTDEBUG && _d("InnoDB version:", $innodb_version);
return $innodb_version;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
no Lmo;
1;
}
# ###########################################################################
# End VersionParser package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# MasterSlave package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MasterSlave.pm
# t/lib/MasterSlave.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MasterSlave;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub check_recursion_method {
my ($methods) = @_;
if ( @$methods != 1 ) {
if ( grep({ !m/processlist|hosts/i } @$methods)
&& $methods->[0] !~ /^dsn=/i )
{
die "Invalid combination of recursion methods: "
. join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". "
. "Only hosts and processlist may be combined.\n"
}
}
else {
my ($method) = @$methods;
die "Invalid recursion method: " . ( $method || 'undef' )
unless $method && $method =~ m/^(?:processlist$|hosts$|none$|dsn=)/i;
}
}
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(OptionParser DSNParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
%args,
replication_thread => {},
};
return bless $self, $class;
}
sub get_slaves {
my ($self, %args) = @_;
my @required_args = qw(make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($make_cxn) = @args{@required_args};
my $slaves = [];
my $dp = $self->{DSNParser};
my $methods = $self->_resolve_recursion_methods($args{dsn});
return $slaves unless @$methods;
if ( grep { m/processlist|hosts/i } @$methods ) {
my @required_args = qw(dbh dsn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $dsn) = @args{@required_args};
$self->recurse_to_slaves(
{ dbh => $dbh,
dsn => $dsn,
callback => sub {
my ( $dsn, $dbh, $level, $parent ) = @_;
return unless $level;
PTDEBUG && _d('Found slave:', $dp->as_string($dsn));
push @$slaves, $make_cxn->(dsn => $dsn, dbh => $dbh);
return;
},
}
);
}
elsif ( $methods->[0] =~ m/^dsn=/i ) {
(my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i;
$slaves = $self->get_cxn_from_dsn_table(
%args,
dsn_table_dsn => $dsn_table_dsn,
);
}
elsif ( $methods->[0] =~ m/none/i ) {
PTDEBUG && _d('Not getting to slaves');
}
else {
die "Unexpected recursion methods: @$methods";
}
return $slaves;
}
sub _resolve_recursion_methods {
my ($self, $dsn) = @_;
my $o = $self->{OptionParser};
if ( $o->got('recursion-method') ) {
return $o->get('recursion-method');
}
elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) {
PTDEBUG && _d('Port number is non-standard; using only hosts method');
return [qw(hosts)];
}
else {
return $o->get('recursion-method');
}
}
sub recurse_to_slaves {
my ( $self, $args, $level ) = @_;
$level ||= 0;
my $dp = $self->{DSNParser};
my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse');
my $dsn = $args->{dsn};
my $methods = $self->_resolve_recursion_methods($dsn);
PTDEBUG && _d('Recursion methods:', @$methods);
if ( lc($methods->[0]) eq 'none' ) {
PTDEBUG && _d('Not recursing to slaves');
return;
}
my $dbh;
eval {
$dbh = $args->{dbh} || $dp->get_dbh(
$dp->get_cxn_params($dsn), { AutoCommit => 1 });
PTDEBUG && _d('Connected to', $dp->as_string($dsn));
};
if ( $EVAL_ERROR ) {
print STDERR "Cannot connect to ", $dp->as_string($dsn), "\n"
or die "Cannot print: $OS_ERROR";
return;
}
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
my ($id) = $dbh->selectrow_array($sql);
PTDEBUG && _d('Working on server ID', $id);
my $master_thinks_i_am = $dsn->{server_id};
if ( !defined $id
|| ( defined $master_thinks_i_am && $master_thinks_i_am != $id )
|| $args->{server_ids_seen}->{$id}++
) {
PTDEBUG && _d('Server ID seen, or not what master said');
if ( $args->{skip_callback} ) {
$args->{skip_callback}->($dsn, $dbh, $level, $args->{parent});
}
return;
}
$args->{callback}->($dsn, $dbh, $level, $args->{parent});
if ( !defined $recurse || $level < $recurse ) {
my @slaves =
grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves.
$self->find_slave_hosts($dp, $dbh, $dsn, $methods);
foreach my $slave ( @slaves ) {
PTDEBUG && _d('Recursing from',
$dp->as_string($dsn), 'to', $dp->as_string($slave));
$self->recurse_to_slaves(
{ %$args, dsn => $slave, dbh => undef, parent => $dsn }, $level + 1 );
}
}
}
sub find_slave_hosts {
my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_;
PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn),
'using methods', @$methods);
my @slaves;
METHOD:
foreach my $method ( @$methods ) {
my $find_slaves = "_find_slaves_by_$method";
PTDEBUG && _d('Finding slaves with', $find_slaves);
@slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn);
last METHOD if @slaves;
}
PTDEBUG && _d('Found', scalar(@slaves), 'slaves');
return @slaves;
}
sub _find_slaves_by_processlist {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves = map {
my $slave = $dsn_parser->parse("h=$_", $dsn);
$slave->{source} = 'processlist';
$slave;
}
grep { $_ }
map {
my ( $host ) = $_->{host} =~ m/^([^:]+):/;
if ( $host eq 'localhost' ) {
$host = '127.0.0.1'; # Replication never uses sockets.
}
$host;
} $self->get_connected_slaves($dbh);
return @slaves;
}
sub _find_slaves_by_hosts {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves;
my $sql = 'SHOW SLAVE HOSTS';
PTDEBUG && _d($dbh, $sql);
@slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })};
if ( @slaves ) {
PTDEBUG && _d('Found some SHOW SLAVE HOSTS info');
@slaves = map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
my $spec = "h=$hash{host},P=$hash{port}"
. ( $hash{user} ? ",u=$hash{user}" : '')
. ( $hash{password} ? ",p=$hash{password}" : '');
my $dsn = $dsn_parser->parse($spec, $dsn);
$dsn->{server_id} = $hash{server_id};
$dsn->{master_id} = $hash{master_id};
$dsn->{source} = 'hosts';
$dsn;
} @slaves;
}
return @slaves;
}
sub get_connected_slaves {
my ( $self, $dbh ) = @_;
my $show = "SHOW GRANTS FOR ";
my $user = 'CURRENT_USER()';
my $sql = $show . $user;
PTDEBUG && _d($dbh, $sql);
my $proc;
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
if ( $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) {
PTDEBUG && _d('Retrying SHOW GRANTS without host; error:',
$EVAL_ERROR);
($user) = split('@', $user);
$sql = $show . $user;
PTDEBUG && _d($sql);
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
}
die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR;
}
if ( !$proc ) {
die "You do not have the PROCESS privilege";
}
$sql = 'SHOW PROCESSLIST';
PTDEBUG && _d($dbh, $sql);
grep { $_->{command} =~ m/Binlog Dump/i }
map { # Lowercase the column names
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{$dbh->selectall_arrayref($sql, { Slice => {} })};
}
sub is_master_of {
my ( $self, $master, $slave ) = @_;
my $master_status = $self->get_master_status($master)
or die "The server specified as a master is not a master";
my $slave_status = $self->get_slave_status($slave)
or die "The server specified as a slave is not a slave";
my @connected = $self->get_connected_slaves($master)
or die "The server specified as a master has no connected slaves";
my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'");
if ( $port != $slave_status->{master_port} ) {
die "The slave is connected to $slave_status->{master_port} "
. "but the master's port is $port";
}
if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) {
die "I don't see any slave I/O thread connected with user "
. $slave_status->{master_user};
}
if ( ($slave_status->{slave_io_state} || '')
eq 'Waiting for master to send event' )
{
my ( $master_log_name, $master_log_num )
= $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
my ( $slave_log_name, $slave_log_num )
= $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
if ( $master_log_name ne $slave_log_name
|| abs($master_log_num - $slave_log_num) > 1 )
{
die "The slave thinks it is reading from "
. "$slave_status->{master_log_file}, but the "
. "master is writing to $master_status->{file}";
}
}
return 1;
}
sub get_master_dsn {
my ( $self, $dbh, $dsn, $dsn_parser ) = @_;
my $master = $self->get_slave_status($dbh) or return undef;
my $spec = "h=$master->{master_host},P=$master->{master_port}";
return $dsn_parser->parse($spec, $dsn);
}
sub get_slave_status {
my ( $self, $dbh ) = @_;
if ( !$self->{not_a_slave}->{$dbh} ) {
my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS}
||= $dbh->prepare('SHOW SLAVE STATUS');
PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS');
$sth->execute();
my ($ss) = @{$sth->fetchall_arrayref({})};
if ( $ss && %$ss ) {
$ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys
return $ss;
}
PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS');
$self->{not_a_slave}->{$dbh}++;
}
}
sub get_master_status {
my ( $self, $dbh ) = @_;
if ( $self->{not_a_master}->{$dbh} ) {
PTDEBUG && _d('Server on dbh', $dbh, 'is not a master');
return;
}
my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS}
||= $dbh->prepare('SHOW MASTER STATUS');
PTDEBUG && _d($dbh, 'SHOW MASTER STATUS');
$sth->execute();
my ($ms) = @{$sth->fetchall_arrayref({})};
PTDEBUG && _d(
$ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms
: '');
if ( !$ms || scalar keys %$ms < 2 ) {
PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master');
$self->{not_a_master}->{$dbh}++;
}
return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys
}
sub wait_for_master {
my ( $self, %args ) = @_;
my @required_args = qw(master_status slave_dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($master_status, $slave_dbh) = @args{@required_args};
my $timeout = $args{timeout} || 60;
my $result;
my $waited;
if ( $master_status ) {
my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', "
. "$master_status->{position}, $timeout)";
PTDEBUG && _d($slave_dbh, $sql);
my $start = time;
($result) = $slave_dbh->selectrow_array($sql);
$waited = time - $start;
PTDEBUG && _d('Result of waiting:', $result);
PTDEBUG && _d("Waited", $waited, "seconds");
}
else {
PTDEBUG && _d('Not waiting: this server is not a master');
}
return {
result => $result,
waited => $waited,
};
}
sub stop_slave {
my ( $self, $dbh ) = @_;
my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE}
||= $dbh->prepare('STOP SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
sub start_slave {
my ( $self, $dbh, $pos ) = @_;
if ( $pos ) {
my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', "
. "MASTER_LOG_POS=$pos->{position}";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
else {
my $sth = $self->{sths}->{$dbh}->{START_SLAVE}
||= $dbh->prepare('START SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
}
sub catchup_to_master {
my ( $self, $slave, $master, $timeout ) = @_;
$self->stop_slave($master);
$self->stop_slave($slave);
my $slave_status = $self->get_slave_status($slave);
my $slave_pos = $self->repl_posn($slave_status);
my $master_status = $self->get_master_status($master);
my $master_pos = $self->repl_posn($master_status);
PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
my $result;
if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) {
PTDEBUG && _d('Waiting for slave to catch up to master');
$self->start_slave($slave, $master_pos);
$result = $self->wait_for_master(
master_status => $master_status,
slave_dbh => $slave,
timeout => $timeout,
master_status => $master_status
);
if ( !defined $result->{result} ) {
$slave_status = $self->get_slave_status($slave);
if ( !$self->slave_is_running($slave_status) ) {
PTDEBUG && _d('Master position:',
$self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
$slave_pos = $self->repl_posn($slave_status);
if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) {
die "MASTER_POS_WAIT() returned NULL but slave has not "
. "caught up to master";
}
PTDEBUG && _d('Slave is caught up to master and stopped');
}
else {
die "Slave has not caught up to master and it is still running";
}
}
}
else {
PTDEBUG && _d("Slave is already caught up to master");
}
return $result;
}
sub catchup_to_same_pos {
my ( $self, $s1_dbh, $s2_dbh ) = @_;
$self->stop_slave($s1_dbh);
$self->stop_slave($s2_dbh);
my $s1_status = $self->get_slave_status($s1_dbh);
my $s2_status = $self->get_slave_status($s2_dbh);
my $s1_pos = $self->repl_posn($s1_status);
my $s2_pos = $self->repl_posn($s2_status);
if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) {
$self->start_slave($s1_dbh, $s2_pos);
}
elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) {
$self->start_slave($s2_dbh, $s1_pos);
}
$s1_status = $self->get_slave_status($s1_dbh);
$s2_status = $self->get_slave_status($s2_dbh);
$s1_pos = $self->repl_posn($s1_status);
$s2_pos = $self->repl_posn($s2_status);
if ( $self->slave_is_running($s1_status)
|| $self->slave_is_running($s2_status)
|| $self->pos_cmp($s1_pos, $s2_pos) != 0)
{
die "The servers aren't both stopped at the same position";
}
}
sub slave_is_running {
my ( $self, $slave_status ) = @_;
return ($slave_status->{slave_sql_running} || 'No') eq 'Yes';
}
sub has_slave_updates {
my ( $self, $dbh ) = @_;
my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'};
PTDEBUG && _d($dbh, $sql);
my ($name, $value) = $dbh->selectrow_array($sql);
return $value && $value =~ m/^(1|ON)$/;
}
sub repl_posn {
my ( $self, $status ) = @_;
if ( exists $status->{file} && exists $status->{position} ) {
return {
file => $status->{file},
position => $status->{position},
};
}
else {
return {
file => $status->{relay_master_log_file},
position => $status->{exec_master_log_pos},
};
}
}
sub get_slave_lag {
my ( $self, $dbh ) = @_;
my $stat = $self->get_slave_status($dbh);
return unless $stat; # server is not a slave
return $stat->{seconds_behind_master};
}
sub pos_cmp {
my ( $self, $a, $b ) = @_;
return $self->pos_to_string($a) cmp $self->pos_to_string($b);
}
sub short_host {
my ( $self, $dsn ) = @_;
my ($host, $port);
if ( $dsn->{master_host} ) {
$host = $dsn->{master_host};
$port = $dsn->{master_port};
}
else {
$host = $dsn->{h};
$port = $dsn->{P};
}
return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" );
}
sub is_replication_thread {
my ( $self, $query, %args ) = @_;
return unless $query;
my $type = lc($args{type} || 'all');
die "Invalid type: $type"
unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i;
my $match = 0;
if ( $type =~ m/binlog_dump|all/i ) {
$match = 1
if ($query->{Command} || $query->{command} || '') eq "Binlog Dump";
}
if ( !$match ) {
if ( ($query->{User} || $query->{user} || '') eq "system user" ) {
PTDEBUG && _d("Slave replication thread");
if ( $type ne 'all' ) {
my $state = $query->{State} || $query->{state} || '';
if ( $state =~ m/^init|end$/ ) {
PTDEBUG && _d("Special state:", $state);
$match = 1;
}
else {
my ($slave_sql) = $state =~ m/
^(Waiting\sfor\sthe\snext\sevent
|Reading\sevent\sfrom\sthe\srelay\slog
|Has\sread\sall\srelay\slog;\swaiting
|Making\stemp\sfile
|Waiting\sfor\sslave\smutex\son\sexit)/xi;
$match = $type eq 'slave_sql' && $slave_sql ? 1
: $type eq 'slave_io' && !$slave_sql ? 1
: 0;
}
}
else {
$match = 1;
}
}
else {
PTDEBUG && _d('Not system user');
}
if ( !defined $args{check_known_ids} || $args{check_known_ids} ) {
my $id = $query->{Id} || $query->{id};
if ( $match ) {
$self->{replication_thread}->{$id} = 1;
}
else {
if ( $self->{replication_thread}->{$id} ) {
PTDEBUG && _d("Thread ID is a known replication thread ID");
$match = 1;
}
}
}
}
PTDEBUG && _d('Matches', $type, 'replication thread:',
($match ? 'yes' : 'no'), '; match:', $match);
return $match;
}
sub get_replication_filters {
my ( $self, %args ) = @_;
my @required_args = qw(dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh) = @args{@required_args};
my %filters = ();
my $status = $self->get_master_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
binlog_do_db
binlog_ignore_db
);
}
$status = $self->get_slave_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
replicate_do_db
replicate_ignore_db
replicate_do_table
replicate_ignore_table
replicate_wild_do_table
replicate_wild_ignore_table
);
my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'";
PTDEBUG && _d($dbh, $sql);
my $row = $dbh->selectrow_arrayref($sql);
$filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF';
}
return \%filters;
}
sub pos_to_string {
my ( $self, $pos ) = @_;
my $fmt = '%s/%020d';
return sprintf($fmt, @{$pos}{qw(file position)});
}
sub reset_known_replication_threads {
my ( $self ) = @_;
$self->{replication_thread} = {};
return;
}
sub get_cxn_from_dsn_table {
my ($self, %args) = @_;
my @required_args = qw(dsn_table_dsn make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dsn_table_dsn, $make_cxn) = @args{@required_args};
PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn);
my $dp = $self->{DSNParser};
my $q = $self->{Quoter};
my $dsn = $dp->parse($dsn_table_dsn);
my $dsn_table;
if ( $dsn->{D} && $dsn->{t} ) {
$dsn_table = $q->quote($dsn->{D}, $dsn->{t});
}
elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) {
$dsn_table = $q->quote($q->split_unquote($dsn->{t}));
}
else {
die "DSN table DSN does not specify a database (D) "
. "or a database-qualified table (t)";
}
my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn);
my $dbh = $dsn_tbl_cxn->connect();
my $sql = "SELECT dsn FROM $dsn_table ORDER BY id";
PTDEBUG && _d($sql);
my $dsn_strings = $dbh->selectcol_arrayref($sql);
my @cxn;
if ( $dsn_strings ) {
foreach my $dsn_string ( @$dsn_strings ) {
PTDEBUG && _d('DSN from DSN table:', $dsn_string);
push @cxn, $make_cxn->(dsn_string => $dsn_string);
}
}
return \@cxn;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MasterSlave package
# ###########################################################################
# ###########################################################################
# Daemon package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Daemon.pm
# t/lib/Daemon.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Daemon;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(setsid);
sub new {
my ( $class, %args ) = @_;
foreach my $arg ( qw(o) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $o = $args{o};
my $self = {
o => $o,
log_file => $o->has('log') ? $o->get('log') : undef,
PID_file => $o->has('pid') ? $o->get('pid') : undef,
};
check_PID_file(undef, $self->{PID_file});
PTDEBUG && _d('Daemonized child will log to', $self->{log_file});
return bless $self, $class;
}
sub daemonize {
my ( $self ) = @_;
PTDEBUG && _d('About to fork and daemonize');
defined (my $pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $pid ) {
PTDEBUG && _d('Parent PID', $PID, 'exiting after forking child PID',$pid);
exit;
}
PTDEBUG && _d('Daemonizing child PID', $PID);
$self->{PID_owner} = $PID;
$self->{child} = 1;
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
$self->_make_PID_file();
$OUTPUT_AUTOFLUSH = 1;
PTDEBUG && _d('Redirecting STDIN to /dev/null');
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
if ( $self->{log_file} ) {
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $self->{log_file});
close STDOUT;
open STDOUT, '>>', $self->{log_file}
or die "Cannot open log file $self->{log_file}: $OS_ERROR";
close STDERR;
open STDERR, ">&STDOUT"
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
}
else {
if ( -t STDOUT ) {
PTDEBUG && _d('No log file and STDOUT is a terminal;',
'redirecting to /dev/null');
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
PTDEBUG && _d('No log file and STDERR is a terminal;',
'redirecting to /dev/null');
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
return;
}
sub check_PID_file {
my ( $self, $file ) = @_;
my $PID_file = $self ? $self->{PID_file} : $file;
PTDEBUG && _d('Checking PID file', $PID_file);
if ( $PID_file && -f $PID_file ) {
my $pid;
eval {
chomp($pid = (slurp_file($PID_file) || ''));
};
if ( $EVAL_ERROR ) {
die "The PID file $PID_file already exists but it cannot be read: "
. $EVAL_ERROR;
}
PTDEBUG && _d('PID file exists; it contains PID', $pid);
if ( $pid ) {
my $pid_is_alive = kill 0, $pid;
if ( $pid_is_alive ) {
die "The PID file $PID_file already exists "
. " and the PID that it contains, $pid, is running";
}
else {
warn "Overwriting PID file $PID_file because the PID that it "
. "contains, $pid, is not running";
}
}
else {
die "The PID file $PID_file already exists but it does not "
. "contain a PID";
}
}
else {
PTDEBUG && _d('No PID file');
}
return;
}
sub make_PID_file {
my ( $self ) = @_;
if ( exists $self->{child} ) {
die "Do not call Daemon::make_PID_file() for daemonized scripts";
}
$self->_make_PID_file();
$self->{PID_owner} = $PID;
return;
}
sub _make_PID_file {
my ( $self ) = @_;
my $PID_file = $self->{PID_file};
if ( !$PID_file ) {
PTDEBUG && _d('No PID file to create');
return;
}
$self->check_PID_file();
open my $PID_FH, '>', $PID_file
or die "Cannot open PID file $PID_file: $OS_ERROR";
print $PID_FH $PID
or die "Cannot print to PID file $PID_file: $OS_ERROR";
close $PID_FH
or die "Cannot close PID file $PID_file: $OS_ERROR";
PTDEBUG && _d('Created PID file:', $self->{PID_file});
return;
}
sub _remove_PID_file {
my ( $self ) = @_;
if ( $self->{PID_file} && -f $self->{PID_file} ) {
unlink $self->{PID_file}
or warn "Cannot remove PID file $self->{PID_file}: $OS_ERROR";
PTDEBUG && _d('Removed PID file');
}
else {
PTDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ( $self ) = @_;
$self->_remove_PID_file() if ($self->{PID_owner} || 0) == $PID;
return;
}
sub slurp_file {
my ($file) = @_;
return unless $file;
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
return do { local $/; <$fh> };
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Daemon package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
{
my $file = 'percona-version-check';
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => md5_hex( hostname() ),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
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}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_slave_restart;
use English qw(-no_match_vars);
use IO::File;
use List::Util qw(min max);
use Time::HiRes qw(sleep);
use sigtrap qw(handler finish untrapped normal-signals);
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
$OUTPUT_AUTOFLUSH = 1;
my $o;
my $dp;
my $q = new Quoter();
my %children;
sub main {
local @ARGV = @_; # set global ARGV for this package
# ########################################################################
# Get configuration information.
# ########################################################################
$o = new OptionParser();
$o->get_specs();
$o->get_opts();
$dp = $o->DSNParser();
$dp->prop('set-vars', $o->set_vars());
$o->set('verbose', 0) if $o->get('quiet');
if ( !$o->get('help') ) {
if ( $o->get('until-master') ) {
if ( $o->get('until-master') !~ m/^[.\w-]+,\d+$/ ) {
$o->save_error("Invalid --until-master argument, must be file,pos");
}
}
if ( $o->get('until-relay') ) {
if ( $o->get('until-relay') !~ m/^[.\w-]+,\d+$/ ) {
$o->save_error("Invalid --until-relay argument, must be file,pos");
}
}
}
eval {
MasterSlave::check_recursion_method($o->get('recursion-method'));
};
if ( $EVAL_ERROR ) {
$o->save_error("Invalid --recursion-method: $EVAL_ERROR")
}
$o->usage_or_errors();
# ########################################################################
# First things first: if --stop was given, create the sentinel file.
# ########################################################################
my $sentinel = $o->get('sentinel');
if ( $o->get('stop') ) {
PTDEBUG && _d('Creating sentinel file', $sentinel);
my $file = IO::File->new($sentinel, ">>")
or die "Cannot open $sentinel: $OS_ERROR\n";
print $file "Remove this file to permit pt-slave-restart to run\n"
or die "Cannot write to $sentinel: $OS_ERROR\n";
close $file
or die "Cannot close $sentinel: $OS_ERROR\n";
print STDOUT "Successfully created file $sentinel\n"
unless $o->get('quiet');
# Exit unlesss --monitor is given.
if ( !$o->got('monitor') ) {
PTDEBUG && _d('Nothing more to do, quitting');
return 0;
}
else {
# Wait for all other running instances to quit, assuming they have the
# same --interval as this invocation. Then remove the file and
# continue.
PTDEBUG && _d('Waiting for other instances to quit');
sleep $o->get('max-sleep');
PTDEBUG && _d('Unlinking', $sentinel);
unlink $sentinel
or die "Cannot unlink $sentinel: $OS_ERROR";
}
}
# ########################################################################
# Connect to MySQL.
# ########################################################################
if ( $o->get('ask-pass') ) {
$o->set('password', OptionParser::prompt_noecho("Enter password: "));
}
my $dsn_defaults = $dp->parse_options($o);
my $dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults)
: $dsn_defaults;
my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn),
{ AutoCommit => 1, });
$dbh->{InactiveDestroy} = 1; # Don't disconnect on fork/daemonize
# Daemonize only after connecting and doing --ask-pass.
my $daemon;
if ( $o->get('daemonize') ) {
$daemon = new Daemon(o=>$o);
$daemon->daemonize();
PTDEBUG && _d('I am a daemon now');
}
elsif ( $o->get('pid') ) {
# We're not daemoninzing, it just handles PID stuff.
$daemon = new Daemon(o=>$o);
$daemon->make_PID_file();
}
# ########################################################################
# Start monitoring the slave.
# ########################################################################
my $exit_status = 0;
my @servers_to_watch;
# Despite the name, recursing to slaves actually begins at the specified
# server, so the named server may also be watched, if it's a slave.
my $ms = new MasterSlave(
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
);
$ms->recurse_to_slaves(
{ dbh => $dbh,
dsn => $dsn,
callback => sub {
my ( $dsn, $dbh, $level ) = @_;
# Test whether we want to watch this server.
eval {
my $stat = $ms->get_slave_status($dbh);
if ( $stat ) {
push @servers_to_watch, { dsn => $dsn, dbh => $dbh };
}
else {
die "could not find slave status on this server\n";
}
};
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
PTDEBUG && _d('Not watching', $dp->as_string($dsn),
'because', $EVAL_ERROR);
}
},
skip_callback => sub {
my ( $dsn, $dbh, $level ) = @_;
print STDERR "Skipping ", $dp->as_string($dsn), "\n";
},
}
);
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [ { dbh => $dbh, dsn => $dsn }, @servers_to_watch ],
);
}
# ########################################################################
# Watch each server found.
# ########################################################################
my $must_fork = @servers_to_watch > 1;
foreach my $host ( @servers_to_watch ) {
$host->{dbh}->{InactiveDestroy} = 1; # Don't disconnect on fork
# Fork, but only if there might be more than one host to watch.
my $pid = $must_fork ? fork() : undef;
if ( !$must_fork || (defined($pid) && $pid == 0) ) {
# I either forked and I'm a child, or I didn't fork... confusing, eh?
watch_server($host->{dsn}, $host->{dbh}, $must_fork, $ms);
}
elsif ( $must_fork && !defined($pid) ) {
die("Unable to fork!");
}
# I already exited if I'm a child, so I'm the parent. (Or maybe I never
# forked).
$children{$dp->as_string($host->{dsn})} = $pid if $must_fork;
}
PTDEBUG && _d('Child PIDs:', values %children);
# Wait for the children to exit.
foreach my $host ( keys %children ) {
PTDEBUG && _d('Waiting to reap', $host);
my $pid = waitpid($children{$host}, 0);
$exit_status ||= $CHILD_ERROR >> 8;
}
$dp->disconnect($dbh);
return $exit_status;
}
# ############################################################################
# Subroutines.
# ############################################################################
# Actually watch a server. If many instances are being watched, this is
# fork()ed.
sub watch_server {
my ( $dsn, $dbh, $was_forked, $ms ) = @_;
PTDEBUG && _d('Watching server', $dp->as_string($dsn),
'forked:', $was_forked);
my $start_sql = VersionParser->new($dbh) >= '4.0.5'
? 'START SLAVE' : 'SLAVE START';
if ( $o->get('until-master') ) {
my ( $file, $pos ) = split(',', $o->get('until-master'));
$start_sql .= " UNTIL MASTER_LOG_FILE = '$file', MASTER_LOG_POS = $pos";
}
elsif ( $o->get('until-relay') ) {
my ( $file, $pos ) = split(',', $o->get('until-relay'));
$start_sql .= " UNTIL RELAY_LOG_FILE = '$file', RELAY_LOG_POS = $pos";
}
my $start = $dbh->prepare($start_sql);
my $stop = $dbh->prepare('STOP SLAVE');
# ########################################################################
# Detect if GTID is enabled. Skipping an event is done differently.
# ########################################################################
# When MySQL 5.6.5 or higher is used and gtid is enabled, skipping a
# transaction is not possible with SQL_SLAVE_SKIP_COUNTER
my $skip_event;
my $have_gtid = 0;
if ( VersionParser->new($dbh) >= '5.6.5' ) {
my $row = $dbh->selectrow_arrayref('SELECT @@GLOBAL.gtid_mode');
PTDEBUG && _d('@@GLOBAL.gtid_mode:', $row->[0]);
if ( $row && $row->[0] eq 'ON' ) {
$have_gtid = 1;
}
}
PTDEBUG && _d('Have GTID:', $have_gtid);
# If GTID is enabled, slave_parallel_workers should be == 0.
# It's currently not possible to know what GTID event the failed trx is.
if ( $have_gtid ) {
my $threads = $dbh->selectrow_hashref(
'SELECT @@GLOBAL.slave_parallel_workers AS threads');
if ( $threads->{threads} > 0 ) {
die "Cannot skip transactions properly because GTID is enabled "
. "and slave_parallel_workers > 0. See 'GLOBAL TRANSACTION IDS' "
. "in the tool's documentation.\n";
}
}
# ########################################################################
# Lookup tables of things to do when a problem is detected.
# ########################################################################
my @error_patterns = (
[ qr/You have an error in your SQL/ => 'refetch_relay_log' ],
[ qr/Could not parse relay log event entry/ => 'refetch_relay_log' ],
[ qr/Incorrect key file for table/ => 'repair_table' ],
# This must be the last one. It's a catch-all rule: skip and restart.
[ qr/./ => ($have_gtid ? 'skip_gtid' : 'skip') ],
);
# ########################################################################
# These are actions to take when an error is found.
# ########################################################################
my %actions = (
refetch_relay_log => sub {
my ( $stat, $dbh ) = @_;
PTDEBUG && _d('Found relay log corruption');
# Can't do CHANGE MASTER TO with a running slave.
$stop->execute();
# Cannot use ? placeholders for CHANGE MASTER values:
# https://bugs.launchpad.net/percona-toolkit/+bug/932614
my $sql = "CHANGE MASTER TO "
. "MASTER_LOG_FILE='$stat->{relay_master_log_file}', "
. "MASTER_LOG_POS=$stat->{exec_master_log_pos}";
PTDEBUG && _d($sql);
$dbh->do($sql);
},
skip => sub {
my ( $stat, $dbh ) = @_;
my $set_skip = $dbh->prepare("SET GLOBAL SQL_SLAVE_SKIP_COUNTER = "
. $o->get('skip-count'));
$set_skip->execute();
},
skip_gtid => sub {
my ( $stat, $dbh ) = @_;
# Get master_uuid from SHOW SLAVE STATUS if a UUID is not specified
# with --master-uuid.
my $gtid_uuid = $o->get('master-uuid');
if ( !$gtid_uuid ) {
$gtid_uuid = $stat->{master_uuid};
die "No master_uuid" unless $gtid_uuid; # shouldn't happen
}
# We need the highest transaction in the executed_gtid_set.
# and then we need to increase it by 1 (the one we want to skip)
# Notes:
# - does not work with parallel replication
# - it skips the next transaction from the master_uuid
# (when a slaveB is replicating from slaveA,
# the master_uuid is it's own master, slaveA)
my ($gtid_exec_ids) = ($stat->{executed_gtid_set} || '') =~ m/$gtid_uuid([0-9-:]*)/;
$gtid_exec_ids =~ s/:[0-9]-/:/g;
die "No executed GTIDs" unless $gtid_exec_ids;
my @gtid_exec_ranges = split(/:/, $gtid_exec_ids);
delete $gtid_exec_ranges[0]; # undef the first value, it's always empty
# Get the highest id by sorting the array, removing the undef value.
my @gtid_exec_sorted = sort { $a <=> $b }
grep { defined($_) } @gtid_exec_ranges;
my $gtid_exec_last = $gtid_exec_sorted[-1];
PTDEBUG && _d("\n",
"GTID: master_uuid:", $gtid_uuid, "\n",
"GTID: executed_gtid_set:", $gtid_exec_ids, "\n",
"GTID: max for master_uuid:", $gtid_exec_sorted[-1], "\n",
"GTID: last executed gtid:", $gtid_uuid, ":", $gtid_exec_last);
# Set the sessions next gtid, write an empty transaction
my $skipped = 0;
while ( $skipped++ < $o->get('skip-count') ) {
my $gtid_next = $gtid_exec_last + $skipped;
my $sql = "SET GTID_NEXT='$gtid_uuid:$gtid_next'";
PTDEBUG && _d($sql);
my $sth = $dbh->prepare($sql);
$sth->execute();
$dbh->begin_work();
$dbh->commit();
}
# Set the session back to the automatically generated GTID_NEXT.
$dbh->do("SET GTID_NEXT='AUTOMATIC'");
},
repair_table => sub {
my ( $stat, $dbh ) = @_;
PTDEBUG && _d('Found corrupt table');
# [ qr/Incorrect key file for table './foo/bar.MYI'
my ( $db, $tbl ) = $stat->{last_error} =~ m!([^/]+)/(.*?)\.MYI!;
if ( $db && $tbl ) {
my $sql = "REPAIR TABLE " . $q->quote($db, $tbl);
PTDEBUG && _d($sql);
$dbh->do($sql);
}
},
);
my $err_text = $o->get('error-text');
my $exit_time = time() + ($o->get('run-time') || 0);
my $sleep = $o->get('sleep');
my ($last_log, $last_pos);
my $stat = {}; # Will hold SHOW SLAVE STATUS
STAT:
while ( $stat
&& (!$o->get('run-time') || time() < $exit_time)
&& !-f $o->get('sentinel') ) {
my $increase_sleep = 1;
$stat = $ms->get_slave_status($dbh);
if ( !$stat ) {
print STDERR "No SLAVE STATUS output found on ",
$dp->as_string($dsn), "\n";
next STAT;
}
PTDEBUG && _d('Last/current relay log file:',
$last_log, $stat->{relay_log_file});
PTDEBUG && _d('Last/current relay log pos:',
$last_pos, $stat->{relay_log_pos});
if ( !$last_log
|| $last_log ne $stat->{relay_log_file} # Avoid infinite loops
|| $last_pos != $stat->{relay_log_pos}
) {
$stat->{slave_sql_running} ||= 'No';
$stat->{last_error} ||= '';
$stat->{last_errno} ||= 0;
if ( $o->get('until-master') && pos_ge($stat, 'master') ) {
die "Slave has advanced past " . $o->get('until-master')
. " on master.\n";
}
elsif ( $o->get('until-relay') && pos_ge($stat, 'relay') ) {
die "Slave has advanced past " . $o->get('until-relay')
. " in relay logs.\n";
}
if ( $stat->{slave_sql_running} eq 'No' ) {
# Print the time, error, etc
if ( $o->get('verbose') ) {
my $err = '';
if ( $o->get('verbose') > 1 ) {
($err = $stat->{last_error} || '' ) =~ s/\s+/ /g;
if ( $o->get('error-length') ) {
$err = substr($err, 0, $o->get('error-length'));
}
}
printf("%s %s %s %11d %d %s\n",
ts(time),
$dp->as_string($dsn),
$stat->{relay_log_file},
$stat->{relay_log_pos},
$stat->{last_errno} || 0,
$err
);
}
if ( $o->got('error-numbers')
&& !exists($o->get('error-numbers')->{$stat->{last_errno}}) ) {
die "Error $stat->{last_errno} is not in --error-numbers.\n";
}
elsif ( $err_text
&& $stat->{last_error}
&& $stat->{last_error} !~ m/$err_text/ ) {
die "Error does not match --error-text.\n";
}
elsif ( $stat->{last_error} || $o->get('always') ) {
# What kind of error is it?
foreach my $pat ( @error_patterns ) {
if ( $stat->{last_error} =~ m/$pat->[0]/ ) {
$actions{$pat->[1]}->($stat, $dbh);
last;
}
}
$start->execute();
$increase_sleep = 0;
# Only set this on events I tried to restart. Otherwise there
# could be a race condition: I see it, I record it, but it hasn't
# caused an error yet; so I won't try to restart it when it does.
# (The point of this is to avoid trying to restart the same event
# twice in case another race condition happens -- I restart it,
# then check the server and it hasn't yet cleared the error
# message and restarted the SQL thread).
if ( $o->get('check-relay-log') ) {
$last_log = $stat->{relay_log_file};
$last_pos = $stat->{relay_log_pos};
}
}
else {
PTDEBUG && _d('The slave is stopped, but without error');
$increase_sleep = 1;
}
}
elsif ( $o->get('verbose') > 2 ) {
printf("%s delayed %s sec\n", $dp->as_string($dsn),
(defined $stat->{seconds_behind_master} ?
$stat->{seconds_behind_master} : 'NULL'));
}
}
else {
if ( $o->get('verbose') ) {
print "Not checking slave because relay log file or position has "
. "not changed "
. "(file " . ($last_log || '')
. " pos " . ($last_pos || '') . ")\n";
}
}
# Adjust sleep time.
if ( $increase_sleep ) {
$sleep = min($o->get('max-sleep'), $sleep * 2);
}
else {
$sleep = max($o->get('min-sleep'), $sleep / 2);
}
# Errors are very likely to follow each other in quick succession. NOTE:
# this policy has a side effect with respect to $sleep. Suppose $sleep is
# 512 and pt-slave-restart finds an error; now $sleep is 256, but
# pt-slave-restart sleeps only 1 (the initial value of --sleep). Suppose
# there is no error when it wakes up after 1 second, because 1 was too
# short. Now it doubles $sleep, back to 512. $sleep has the same value
# it did before the error was ever found.
my $sleep_time = $increase_sleep ? $sleep : min($sleep, $o->get('sleep'));
if ( $o->get('verbose') > 2 ) {
printf("%s sleeping %f\n", $dp->as_string($dsn), $sleep_time);
}
sleep $sleep_time;
}
PTDEBUG && _d('All done with server', $dp->as_string($dsn));
if ( $was_forked ) {
$dp->disconnect($dbh);
exit(0);
}
}
# Determines if the $stat's log coordinates are greater than or equal to the
# desired coordinates. $which is 'master' or 'relay'
sub pos_ge {
my ( $stat, $which ) = @_;
my $fmt = '%s/%020d';
my $curr = $which eq 'master'
? sprintf($fmt, @{$stat}{qw(relay_master_log_file exec_master_log_pos)})
: sprintf($fmt, @{$stat}{qw(relay_log_file relay_log_pos)});
my $stop = sprintf($fmt, split(',', $o->get("until-$which")));
return $curr ge $stop;
}
sub ts {
my ( $time ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= localtime($time);
$mon += 1;
$year += 1900;
return sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
}
# Catches signals for exiting gracefully.
sub finish {
my ($signal) = @_;
print STDERR "Exiting on SIG$signal.\n";
if ( %children ) {
kill 9, values %children;
print STDERR "Signaled ", join(', ', values %children), "\n";
}
exit(1);
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation.
# ############################################################################
=pod
=head1 NAME
pt-slave-restart - Watch and restart MySQL replication after errors.
=head1 SYNOPSIS
Usage: pt-slave-restart [OPTIONS] [DSN]
pt-slave-restart watches one or more MySQL replication slaves for
errors, and tries to restart replication if it stops.
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-slave-restart watches one or more MySQL replication slaves and tries to skip
statements that cause errors. It polls slaves intelligently with an
exponentially varying sleep time. You can specify errors to skip and run the
slaves until a certain binlog position.
Although this tool can help a slave advance past errors, you should not
rely on it to "fix" replication. If slave errors occur frequently or
unexpectedly, you should identify and fix the root cause.
=head1 OUTPUT
If you specify L<"--verbose">, pt-slave-restart prints a line every time it sees
the slave has an error. See L<"--verbose"> for details.
=head1 SLEEP
pt-slave-restart sleeps intelligently between polling the slave. The current
sleep time varies.
=over
=item *
The initial sleep time is given by L<"--sleep">.
=item *
If it checks and finds an error, it halves the previous sleep time.
=item *
If it finds no error, it doubles the previous sleep time.
=item *
The sleep time is bounded below by L<"--min-sleep"> and above by
L<"--max-sleep">.
=item *
Immediately after finding an error, pt-slave-restart assumes another error is
very likely to happen next, so it sleeps the current sleep time or the initial
sleep time, whichever is less.
=back
=head1 GLOBAL TRANSACTION IDS
As of Percona Toolkit 2.2.8, pt-slave-restart supports Global Transaction IDs
introduced in MySQL 5.6.5. It's important to keep in mind that:
=over
=item *
pt-slave-restart will not skip transactions when multiple replication threads
are being used (slave_parallel_workers > 0). pt-slave-restart does not know
what the GTID event is of the failed transaction of a specific slave thread.
=item *
The default behavior is to skip the next transaction from the slave's master.
Writes can originate on different servers, each with their own UUID.
See L<"--master-uuid">.
=back
=head1 EXIT STATUS
An exit status of 0 (sometimes also called a return value or return code)
indicates success. Any other value represents the exit status of the Perl
process itself, or of the last forked process that exited if there were multiple
servers to monitor.
=head1 COMPATIBILITY
pt-slave-restart should work on many versions of MySQL. Lettercase of many
output columns from SHOW SLAVE STATUS has changed over time, so it treats them
all as lowercase.
=head1 OPTIONS
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --always
Start slaves even when there is no error. With this option enabled,
pt-slave-restart will not let you stop the slave manually if you want to!
=item --ask-pass
Prompt for a password when connecting to MySQL.
=item --charset
short form: -A; type: string
Default character set. If the value is utf8, sets Perl's binmode on
STDOUT to utf8, passes the mysql_enable_utf8 option to DBD::mysql, and
runs SET NAMES UTF8 after connecting to MySQL. Any other value sets
binmode on STDOUT without the utf8 layer, and runs SET NAMES after
connecting to MySQL.
=item --[no]check-relay-log
default: yes
Check the last relay log file and position before checking for slave errors.
By default pt-slave-restart will not doing anything (it will just sleep)
if neither the relay log file nor the relay log position have changed since
the last check. This prevents infinite loops (i.e. restarting the same
error in the same relay log file at the same relay log position).
For certain slave errors, however, this check needs to be disabled by
specifying C<--no-check-relay-log>. Do not do this unless you know what
you are doing!
=item --config
type: Array
Read this comma-separated list of config files; if specified, this must be the
first option on the command line.
=item --daemonize
Fork to the background and detach from the shell. POSIX
operating systems only.
=item --database
short form: -D; type: string
Database to use.
=item --defaults-file
short form: -F; type: string
Only read mysql options from the given file. You must give an absolute
pathname.
=item --error-length
type: int
Max length of error message to print. When L<"--verbose"> is set high enough to
print the error, this option will truncate the error text to the specified
length. This can be useful to prevent wrapping on the terminal.
=item --error-numbers
type: hash
Only restart this comma-separated list of errors. Makes pt-slave-restart only
try to restart if the error number is in this comma-separated list of errors.
If it sees an error not in the list, it will exit.
The error number is in the C column of C.
=item --error-text
type: string
Only restart errors that match this pattern. A Perl regular expression against
which the error text, if any, is matched. If the error text exists and matches,
pt-slave-restart will try to restart the slave. If it exists but doesn't match,
pt-slave-restart will exit.
The error text is in the C column of C.
=item --help
Show help and exit.
=item --host
short form: -h; type: string
Connect to host.
=item --log
type: string
Print all output to this file when daemonized.
=item --max-sleep
type: float; default: 64
Maximum sleep seconds.
The maximum time pt-slave-restart will sleep before polling the slave again.
This is also the time that pt-slave-restart will wait for all other running
instances to quit if both L<"--stop"> and L<"--monitor"> are specified.
See L<"SLEEP">.
=item --min-sleep
type: float; default: 0.015625
The minimum time pt-slave-restart will sleep before polling the slave again.
See L<"SLEEP">.
=item --monitor
Whether to monitor the slave (default). Unless you specify --monitor
explicitly, L<"--stop"> will disable it.
=item --password
short form: -p; type: string
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item --pid
type: string
Create the given PID file. The tool won't start if the PID file already
exists and the PID it contains is different than the current PID. However,
if the PID file exists and the PID it contains is no longer running, the
tool will overwrite the PID file with the current PID. The PID file is
removed automatically when the tool exits.
=item --port
short form: -P; type: int
Port number to use for connection.
=item --quiet
short form: -q
Suppresses normal output (disables L<"--verbose">).
=item --recurse
type: int; default: 0
Watch slaves of the specified server, up to the specified number of servers deep
in the hierarchy. The default depth of 0 means "just watch the slave
specified."
pt-slave-restart examines C and tries to determine which
connections are from slaves, then connect to them. See L<"--recursion-method">.
Recursion works by finding all slaves when the program starts, then watching
them. If there is more than one slave, C uses C to
monitor them.
This also works if you have configured your slaves to show up in C. The minimal configuration for this is the C parameter, but
there are other "report" parameters as well for the port, username, and
password.
=item --recursion-method
type: array; default: processlist,hosts
Preferred recursion method used to find slaves.
Possible methods are:
METHOD USES
=========== ==================
processlist SHOW PROCESSLIST
hosts SHOW SLAVE HOSTS
none Do not find slaves
The processlist method is preferred because SHOW SLAVE HOSTS is not reliable.
However, the hosts method is required if the server uses a non-standard
port (not 3306). Usually pt-slave-restart does the right thing and finds
the slaves, but you may give a preferred method and it will be used first.
If it doesn't find any slaves, the other methods will be tried.
=item --run-time
type: time
Time to run before exiting. Causes pt-slave-restart to stop after the specified
time has elapsed. Optional suffix: s=seconds, m=minutes, h=hours, d=days; if no
suffix, s is used.
=item --sentinel
type: string; default: /tmp/pt-slave-restart-sentinel
Exit if this file exists.
=item --set-vars
type: Array
Set the MySQL variables in this comma-separated list of C pairs.
By default, the tool sets:
=for comment ignore-pt-internal-value
MAGIC_set_vars
wait_timeout=10000
Variables specified on the command line override these defaults. For
example, specifying C<--set-vars wait_timeout=500> overrides the defaultvalue of C<10000>.
The tool prints a warning and continues if a variable cannot be set.
=item --skip-count
type: int; default: 1
Number of statements to skip when restarting the slave.
=item --master-uuid
type: string
When using GTID, an empty transaction should be created in order to skip it.
If writes are coming from different nodes in the replication tree above, it is
not possible to know which event from which UUID to skip.
By default, transactions from the slave's master (C<'Master_UUID'> from
C) are skipped.
For example, with
master1 -> slave1 -> slave2
When skipping events on slave2 that were written to master1, you must specify
the UUID of master1, else the tool will use the UUID of slave1 by default.
See L<"GLOBAL TRANSACTION IDS">.
=item --sleep
type: int; default: 1
Initial sleep seconds between checking the slave.
See L<"SLEEP">.
=item --socket
short form: -S; type: string
Socket file to use for connection.
=item --stop
Stop running instances by creating the sentinel file.
Causes C to create the sentinel file specified by
L<"--sentinel">. This should have the effect of stopping all running
instances which are watching the same sentinel file. If L<"--monitor"> isn't
specified, C will exit after creating the file. If it is
specified, C will wait the interval given by
L<"--max-sleep">, then remove the file and continue working.
You might find this handy to stop cron jobs gracefully if necessary, or to
replace one running instance with another. For example, if you want to stop
and restart C every hour (just to make sure that it is
restarted every hour, in case of a server crash or some other problem), you
could use a C line like this:
0 * * * * pt-slave-restart --monitor --stop --sentinel /tmp/pt-slave-restartup
The non-default L<"--sentinel"> will make sure the hourly C job stops
only instances previously started with the same options (that is, from the
same C job).
See also L<"--sentinel">.
=item --until-master
type: string
Run until this master log file and position. Start the slave, and retry if it
fails, until it reaches the given replication coordinates. The coordinates are
the logfile and position on the master, given by relay_master_log_file,
exec_master_log_pos. The argument must be in the format "file,pos". Separate
the filename and position with a single comma and no space.
This will also cause an UNTIL clause to be given to START SLAVE.
After reaching this point, the slave should be stopped and pt-slave-restart
will exit.
=item --until-relay
type: string
Run until this relay log file and position. Like L<"--until-master">, but in
the slave's relay logs instead. The coordinates are given by relay_log_file,
relay_log_pos.
=item --user
short form: -u; type: string
User for login if not current user.
=item --verbose
short form: -v; cumulative: yes; default: 1
Be verbose; can specify multiple times. Verbosity 1 outputs connection
information, a timestamp, relay_log_file, relay_log_pos, and last_errno.
Verbosity 2 adds last_error. See also L<"--error-length">. Verbosity 3 prints
the current sleep time each time pt-slave-restart sleeps.
=item --version
Show version and exit.
=item --[no]version-check
default: yes
Check for the latest version of Percona Toolkit, MySQL, and other programs.
This is a standard "check for updates automatically" feature, with two
additional features. First, the tool checks the version of other programs
on the local system in addition to its own version. For example, it checks
the version of every MySQL server it connects to, Perl, and the Perl module
DBD::mysql. Second, it checks for and warns about versions with known
problems. For example, MySQL 5.5.25 had a critical bug and was re-released
as 5.5.25a.
Any updates or known problems are printed to STDOUT before the tool's normal
output. This feature should never interfere with the normal operation of the
tool.
For more information, visit L.
=back
Show version and exit.
=head1 DSN OPTIONS
These DSN options are used to create a DSN. Each option is given like
C. The options are case-sensitive, so P and p are not the
same option. There cannot be whitespace before or after the C<=> and
if the value contains whitespace it must be quoted. DSN options are
comma-separated. See the L manpage for full details.
=over
=item * A
dsn: charset; copy: yes
Default character set.
=item * D
dsn: database; copy: yes
Default database.
=item * F
dsn: mysql_read_default_file; copy: yes
Only read default options from the given file
=item * h
dsn: host; copy: yes
Connect to host.
=item * p
dsn: password; copy: yes
Password to use when connecting.
If password contains commas they must be escaped with a backslash: "exam\,ple"
=item * P
dsn: port; copy: yes
Port number to use for connection.
=item * S
dsn: mysql_socket; copy: yes
Socket file to use for connection.
=item * u
dsn: user; copy: yes
User for login if not current user.
=back
=head1 ENVIRONMENT
The environment variable C enables verbose debugging output to STDERR.
To enable debugging and capture all output to a file, run the tool like:
PTDEBUG=1 pt-slave-restart ... > FILE 2>&1
Be careful: debugging output is voluminous and can generate several megabytes
of output.
=head1 SYSTEM REQUIREMENTS
You need Perl, DBI, DBD::mysql, and some core packages that ought to be
installed in any reasonably new version of Perl.
=head1 BUGS
For a list of known bugs, see L.
Please report bugs at L.
Include the following information in your bug report:
=over
=item * Complete command-line used to run the tool
=item * Tool L<"--version">
=item * MySQL version of all servers involved
=item * Output from the tool including STDERR
=item * Input files (log/dump/config files, etc.)
=back
If possible, include debugging output by running the tool with C;
see L<"ENVIRONMENT">.
=head1 DOWNLOADING
Visit L with the name of any tool.
=head1 AUTHORS
Baron Schwartz
=head1 ABOUT PERCONA TOOLKIT
This tool is part of Percona Toolkit, a collection of advanced command-line
tools for MySQL developed by Percona. Percona Toolkit was forked from two
projects in June, 2011: Maatkit and Aspersa. Those projects were created by
Baron Schwartz and primarily developed by him and Daniel Nichter. Visit
L);
Term::ReadKey::ReadMode('normal');
print "\n"
or die "Cannot print: $OS_ERROR";
};
if ( $EVAL_ERROR ) {
die "Cannot read response; is Term::ReadKey installed? $EVAL_ERROR";
}
return $response;
}
sub _read_config_file {
my ( $self, $filename ) = @_;
open my $fh, "<", $filename or die "Cannot open $filename: $OS_ERROR\n";
my @args;
my $prefix = '--';
my $parse = 1;
LINE:
while ( my $line = <$fh> ) {
chomp $line;
next LINE if $line =~ m/^\s*(?:\#|\;|$)/;
$line =~ s/\s+#.*$//g;
$line =~ s/^\s+|\s+$//g;
if ( $line eq '--' ) {
$prefix = '';
$parse = 0;
next LINE;
}
if ( $parse
&& !$self->has('version-check')
&& $line =~ /version-check/
) {
next LINE;
}
if ( $parse
&& (my($opt, $arg) = $line =~ m/^\s*([^=\s]+?)(?:\s*=\s*(.*?)\s*)?$/)
) {
push @args, grep { defined $_ } ("$prefix$opt", $arg);
}
elsif ( $line =~ m/./ ) {
push @args, $line;
}
else {
die "Syntax error in file $filename at line $INPUT_LINE_NUMBER";
}
}
close $fh;
return @args;
}
sub read_para_after {
my ( $self, $file, $regex ) = @_;
open my $fh, "<", $file or die "Can't open $file: $OS_ERROR";
local $INPUT_RECORD_SEPARATOR = '';
my $para;
while ( $para = <$fh> ) {
next unless $para =~ m/^=pod$/m;
last;
}
while ( $para = <$fh> ) {
next unless $para =~ m/$regex/;
last;
}
$para = <$fh>;
chomp($para);
close $fh or die "Can't close $file: $OS_ERROR";
return $para;
}
sub clone {
my ( $self ) = @_;
my %clone = map {
my $hashref = $self->{$_};
my $val_copy = {};
foreach my $key ( keys %$hashref ) {
my $ref = ref $hashref->{$key};
$val_copy->{$key} = !$ref ? $hashref->{$key}
: $ref eq 'HASH' ? { %{$hashref->{$key}} }
: $ref eq 'ARRAY' ? [ @{$hashref->{$key}} ]
: $hashref->{$key};
}
$_ => $val_copy;
} qw(opts short_opts defaults);
foreach my $scalar ( qw(got_opts) ) {
$clone{$scalar} = $self->{$scalar};
}
return bless \%clone;
}
sub _parse_size {
my ( $self, $opt, $val ) = @_;
if ( lc($val || '') eq 'null' ) {
PTDEBUG && _d('NULL size for', $opt->{long});
$opt->{value} = 'null';
return;
}
my %factor_for = (k => 1_024, M => 1_048_576, G => 1_073_741_824);
my ($pre, $num, $factor) = $val =~ m/^([+-])?(\d+)([kMG])?$/;
if ( defined $num ) {
if ( $factor ) {
$num *= $factor_for{$factor};
PTDEBUG && _d('Setting option', $opt->{y},
'to num', $num, '* factor', $factor);
}
$opt->{value} = ($pre || '') . $num;
}
else {
$self->save_error("Invalid size for --$opt->{long}: $val");
}
return;
}
sub _parse_attribs {
my ( $self, $option, $attribs ) = @_;
my $types = $self->{types};
return $option
. ($attribs->{'short form'} ? '|' . $attribs->{'short form'} : '' )
. ($attribs->{'negatable'} ? '!' : '' )
. ($attribs->{'cumulative'} ? '+' : '' )
. ($attribs->{'type'} ? '=' . $types->{$attribs->{type}} : '' );
}
sub _parse_synopsis {
my ( $self, $file ) = @_;
$file ||= $self->{file} || __FILE__;
PTDEBUG && _d("Parsing SYNOPSIS in", $file);
local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs
open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR";
my $para;
1 while defined($para = <$fh>) && $para !~ m/^=head1 SYNOPSIS/;
die "$file does not contain a SYNOPSIS section" unless $para;
my @synop;
for ( 1..2 ) { # 1 for the usage, 2 for the description
my $para = <$fh>;
push @synop, $para;
}
close $fh;
PTDEBUG && _d("Raw SYNOPSIS text:", @synop);
my ($usage, $desc) = @synop;
die "The SYNOPSIS section in $file is not formatted properly"
unless $usage && $desc;
$usage =~ s/^\s*Usage:\s+(.+)/$1/;
chomp $usage;
$desc =~ s/\n/ /g;
$desc =~ s/\s{2,}/ /g;
$desc =~ s/\. ([A-Z][a-z])/. $1/g;
$desc =~ s/\s+$//;
return (
description => $desc,
usage => $usage,
);
};
sub set_vars {
my ($self, $file) = @_;
$file ||= $self->{file} || __FILE__;
my %user_vars;
my $user_vars = $self->has('set-vars') ? $self->get('set-vars') : undef;
if ( $user_vars ) {
foreach my $var_val ( @$user_vars ) {
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$user_vars{$var} = {
val => $val,
default => 0,
};
}
}
my %default_vars;
my $default_vars = $self->read_para_after($file, qr/MAGIC_set_vars/);
if ( $default_vars ) {
%default_vars = map {
my $var_val = $_;
my ($var, $val) = $var_val =~ m/([^\s=]+)=(\S+)/;
die "Invalid --set-vars value: $var_val\n" unless $var && defined $val;
$var => {
val => $val,
default => 1,
};
} split("\n", $default_vars);
}
my %vars = (
%default_vars, # first the tool's defaults
%user_vars, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--set-vars:', Dumper(\%vars));
return \%vars;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
if ( PTDEBUG ) {
print STDERR '# ', $^X, ' ', $], "\n";
if ( my $uname = `uname -a` ) {
$uname =~ s/\s+/ /g;
print STDERR "# $uname\n";
}
print STDERR '# Arguments: ',
join(' ', map { my $a = "_[$_]_"; $a =~ s/\n/\n# /g; $a; } @ARGV), "\n";
}
1;
}
# ###########################################################################
# End OptionParser package
# ###########################################################################
# ###########################################################################
# Lmo::Utils package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Utils.pm
# t/lib/Lmo/Utils.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Utils;
use strict;
use warnings qw( FATAL all );
require Exporter;
our (@ISA, @EXPORT, @EXPORT_OK);
BEGIN {
@ISA = qw(Exporter);
@EXPORT = @EXPORT_OK = qw(
_install_coderef
_unimport_coderefs
_glob_for
_stash_for
);
}
{
no strict 'refs';
sub _glob_for {
return \*{shift()}
}
sub _stash_for {
return \%{ shift() . "::" };
}
}
sub _install_coderef {
my ($to, $code) = @_;
return *{ _glob_for $to } = $code;
}
sub _unimport_coderefs {
my ($target, @names) = @_;
return unless @names;
my $stash = _stash_for($target);
foreach my $name (@names) {
if ($stash->{$name} and defined(&{$stash->{$name}})) {
delete $stash->{$name};
}
}
}
1;
}
# ###########################################################################
# End Lmo::Utils package
# ###########################################################################
# ###########################################################################
# Lmo::Meta package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Meta.pm
# t/lib/Lmo/Meta.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Meta;
use strict;
use warnings qw( FATAL all );
my %metadata_for;
sub new {
my $class = shift;
return bless { @_ }, $class
}
sub metadata_for {
my $self = shift;
my ($class) = @_;
return $metadata_for{$class} ||= {};
}
sub class { shift->{class} }
sub attributes {
my $self = shift;
return keys %{$self->metadata_for($self->class)}
}
sub attributes_for_new {
my $self = shift;
my @attributes;
my $class_metadata = $self->metadata_for($self->class);
while ( my ($attr, $meta) = each %$class_metadata ) {
if ( exists $meta->{init_arg} ) {
push @attributes, $meta->{init_arg}
if defined $meta->{init_arg};
}
else {
push @attributes, $attr;
}
}
return @attributes;
}
1;
}
# ###########################################################################
# End Lmo::Meta package
# ###########################################################################
# ###########################################################################
# Lmo::Object package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Object.pm
# t/lib/Lmo/Object.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Object;
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(blessed);
use Lmo::Meta;
use Lmo::Utils qw(_glob_for);
sub new {
my $class = shift;
my $args = $class->BUILDARGS(@_);
my $class_metadata = Lmo::Meta->metadata_for($class);
my @args_to_delete;
while ( my ($attr, $meta) = each %$class_metadata ) {
next unless exists $meta->{init_arg};
my $init_arg = $meta->{init_arg};
if ( defined $init_arg ) {
$args->{$attr} = delete $args->{$init_arg};
}
else {
push @args_to_delete, $attr;
}
}
delete $args->{$_} for @args_to_delete;
for my $attribute ( keys %$args ) {
if ( my $coerce = $class_metadata->{$attribute}{coerce} ) {
$args->{$attribute} = $coerce->($args->{$attribute});
}
if ( my $isa_check = $class_metadata->{$attribute}{isa} ) {
my ($check_name, $check_sub) = @$isa_check;
$check_sub->($args->{$attribute});
}
}
while ( my ($attribute, $meta) = each %$class_metadata ) {
next unless $meta->{required};
Carp::confess("Attribute ($attribute) is required for $class")
if ! exists $args->{$attribute}
}
my $self = bless $args, $class;
my @build_subs;
my $linearized_isa = mro::get_linear_isa($class);
for my $isa_class ( @$linearized_isa ) {
unshift @build_subs, *{ _glob_for "${isa_class}::BUILD" }{CODE};
}
my @args = %$args;
for my $sub (grep { defined($_) && exists &$_ } @build_subs) {
$sub->( $self, @args);
}
return $self;
}
sub BUILDARGS {
shift; # No need for the classname
if ( @_ == 1 && ref($_[0]) ) {
Carp::confess("Single parameters to new() must be a HASH ref, not $_[0]")
unless ref($_[0]) eq ref({});
return {%{$_[0]}} # We want a new reference, always
}
else {
return { @_ };
}
}
sub meta {
my $class = shift;
$class = Scalar::Util::blessed($class) || $class;
return Lmo::Meta->new(class => $class);
}
1;
}
# ###########################################################################
# End Lmo::Object package
# ###########################################################################
# ###########################################################################
# Lmo::Types package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo/Types.pm
# t/lib/Lmo/Types.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Lmo::Types;
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
our %TYPES = (
Bool => sub { !$_[0] || (defined $_[0] && looks_like_number($_[0]) && $_[0] == 1) },
Num => sub { defined $_[0] && looks_like_number($_[0]) },
Int => sub { defined $_[0] && looks_like_number($_[0]) && $_[0] == int($_[0]) },
Str => sub { defined $_[0] },
Object => sub { defined $_[0] && blessed($_[0]) },
FileHandle => sub { local $@; require IO::Handle; fileno($_[0]) && $_[0]->opened },
map {
my $type = /R/ ? $_ : uc $_;
$_ . "Ref" => sub { ref $_[0] eq $type }
} qw(Array Code Hash Regexp Glob Scalar)
);
sub check_type_constaints {
my ($attribute, $type_check, $check_name, $val) = @_;
( ref($type_check) eq 'CODE'
? $type_check->($val)
: (ref $val eq $type_check
|| ($val && $val eq $type_check)
|| (exists $TYPES{$type_check} && $TYPES{$type_check}->($val)))
)
|| Carp::confess(
qq
. qq
. (defined $val ? Lmo::Dumper($val) : 'undef') )
}
sub _nested_constraints {
my ($attribute, $aggregate_type, $type) = @_;
my $inner_types;
if ( $type =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$inner_types = _nested_constraints($1, $2);
}
else {
$inner_types = $TYPES{$type};
}
if ( $aggregate_type eq 'ArrayRef' ) {
return sub {
my ($val) = @_;
return unless ref($val) eq ref([]);
if ($inner_types) {
for my $value ( @{$val} ) {
return unless $inner_types->($value)
}
}
else {
for my $value ( @{$val} ) {
return unless $value && ($value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type)));
}
}
return 1;
};
}
elsif ( $aggregate_type eq 'Maybe' ) {
return sub {
my ($value) = @_;
return 1 if ! defined($value);
if ($inner_types) {
return unless $inner_types->($value)
}
else {
return unless $value eq $type
|| (Scalar::Util::blessed($value) && $value->isa($type));
}
return 1;
}
}
else {
Carp::confess("Nested aggregate types are only implemented for ArrayRefs and Maybe");
}
}
1;
}
# ###########################################################################
# End Lmo::Types package
# ###########################################################################
# ###########################################################################
# Lmo package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Lmo.pm
# t/lib/Lmo.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
BEGIN {
$INC{"Lmo.pm"} = __FILE__;
package Lmo;
our $VERSION = '0.30_Percona'; # Forked from 0.30 of Mo.
use strict;
use warnings qw( FATAL all );
use Carp ();
use Scalar::Util qw(looks_like_number blessed);
use Lmo::Meta;
use Lmo::Object;
use Lmo::Types;
use Lmo::Utils;
my %export_for;
sub import {
warnings->import(qw(FATAL all));
strict->import();
my $caller = scalar caller(); # Caller's package
my %exports = (
extends => \&extends,
has => \&has,
with => \&with,
override => \&override,
confess => \&Carp::confess,
);
$export_for{$caller} = \%exports;
for my $keyword ( keys %exports ) {
_install_coderef "${caller}::$keyword" => $exports{$keyword};
}
if ( !@{ *{ _glob_for "${caller}::ISA" }{ARRAY} || [] } ) {
@_ = "Lmo::Object";
goto *{ _glob_for "${caller}::extends" }{CODE};
}
}
sub extends {
my $caller = scalar caller();
for my $class ( @_ ) {
_load_module($class);
}
_set_package_isa($caller, @_);
_set_inherited_metadata($caller);
}
sub _load_module {
my ($class) = @_;
(my $file = $class) =~ s{::|'}{/}g;
$file .= '.pm';
{ local $@; eval { require "$file" } } # or warn $@;
return;
}
sub with {
my $package = scalar caller();
require Role::Tiny;
for my $role ( @_ ) {
_load_module($role);
_role_attribute_metadata($package, $role);
}
Role::Tiny->apply_roles_to_package($package, @_);
}
sub _role_attribute_metadata {
my ($package, $role) = @_;
my $package_meta = Lmo::Meta->metadata_for($package);
my $role_meta = Lmo::Meta->metadata_for($role);
%$package_meta = (%$role_meta, %$package_meta);
}
sub has {
my $names = shift;
my $caller = scalar caller();
my $class_metadata = Lmo::Meta->metadata_for($caller);
for my $attribute ( ref $names ? @$names : $names ) {
my %args = @_;
my $method = ($args{is} || '') eq 'ro'
? sub {
Carp::confess("Cannot assign a value to a read-only accessor at reader ${caller}::${attribute}")
if $#_;
return $_[0]{$attribute};
}
: sub {
return $#_
? $_[0]{$attribute} = $_[1]
: $_[0]{$attribute};
};
$class_metadata->{$attribute} = ();
if ( my $type_check = $args{isa} ) {
my $check_name = $type_check;
if ( my ($aggregate_type, $inner_type) = $type_check =~ /\A(ArrayRef|Maybe)\[(.*)\]\z/ ) {
$type_check = Lmo::Types::_nested_constraints($attribute, $aggregate_type, $inner_type);
}
my $check_sub = sub {
my ($new_val) = @_;
Lmo::Types::check_type_constaints($attribute, $type_check, $check_name, $new_val);
};
$class_metadata->{$attribute}{isa} = [$check_name, $check_sub];
my $orig_method = $method;
$method = sub {
$check_sub->($_[1]) if $#_;
goto &$orig_method;
};
}
if ( my $builder = $args{builder} ) {
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$builder
: goto &$original_method
};
}
if ( my $code = $args{default} ) {
Carp::confess("${caller}::${attribute}'s default is $code, but should be a coderef")
unless ref($code) eq 'CODE';
my $original_method = $method;
$method = sub {
$#_
? goto &$original_method
: ! exists $_[0]{$attribute}
? $_[0]{$attribute} = $_[0]->$code
: goto &$original_method
};
}
if ( my $role = $args{does} ) {
my $original_method = $method;
$method = sub {
if ( $#_ ) {
Carp::confess(qq)
unless Scalar::Util::blessed($_[1]) && eval { $_[1]->does($role) }
}
goto &$original_method
};
}
if ( my $coercion = $args{coerce} ) {
$class_metadata->{$attribute}{coerce} = $coercion;
my $original_method = $method;
$method = sub {
if ( $#_ ) {
return $original_method->($_[0], $coercion->($_[1]))
}
goto &$original_method;
}
}
_install_coderef "${caller}::$attribute" => $method;
if ( $args{required} ) {
$class_metadata->{$attribute}{required} = 1;
}
if ($args{clearer}) {
_install_coderef "${caller}::$args{clearer}"
=> sub { delete shift->{$attribute} }
}
if ($args{predicate}) {
_install_coderef "${caller}::$args{predicate}"
=> sub { exists shift->{$attribute} }
}
if ($args{handles}) {
_has_handles($caller, $attribute, \%args);
}
if (exists $args{init_arg}) {
$class_metadata->{$attribute}{init_arg} = $args{init_arg};
}
}
}
sub _has_handles {
my ($caller, $attribute, $args) = @_;
my $handles = $args->{handles};
my $ref = ref $handles;
my $kv;
if ( $ref eq ref [] ) {
$kv = { map { $_,$_ } @{$handles} };
}
elsif ( $ref eq ref {} ) {
$kv = $handles;
}
elsif ( $ref eq ref qr// ) {
Carp::confess("Cannot delegate methods based on a Regexp without a type constraint (isa)")
unless $args->{isa};
my $target_class = $args->{isa};
$kv = {
map { $_, $_ }
grep { $_ =~ $handles }
grep { !exists $Lmo::Object::{$_} && $target_class->can($_) }
grep { !$export_for{$target_class}->{$_} }
keys %{ _stash_for $target_class }
};
}
else {
Carp::confess("handles for $ref not yet implemented");
}
while ( my ($method, $target) = each %{$kv} ) {
my $name = _glob_for "${caller}::$method";
Carp::confess("You cannot overwrite a locally defined method ($method) with a delegation")
if defined &$name;
my ($target, @curried_args) = ref($target) ? @$target : $target;
*$name = sub {
my $self = shift;
my $delegate_to = $self->$attribute();
my $error = "Cannot delegate $method to $target because the value of $attribute";
Carp::confess("$error is not defined") unless $delegate_to;
Carp::confess("$error is not an object (got '$delegate_to')")
unless Scalar::Util::blessed($delegate_to) || (!ref($delegate_to) && $delegate_to->can($target));
return $delegate_to->$target(@curried_args, @_);
}
}
}
sub _set_package_isa {
my ($package, @new_isa) = @_;
my $package_isa = \*{ _glob_for "${package}::ISA" };
@{*$package_isa} = @new_isa;
}
sub _set_inherited_metadata {
my $class = shift;
my $class_metadata = Lmo::Meta->metadata_for($class);
my $linearized_isa = mro::get_linear_isa($class);
my %new_metadata;
for my $isa_class (reverse @$linearized_isa) {
my $isa_metadata = Lmo::Meta->metadata_for($isa_class);
%new_metadata = (
%new_metadata,
%$isa_metadata,
);
}
%$class_metadata = %new_metadata;
}
sub unimport {
my $caller = scalar caller();
my $target = caller;
_unimport_coderefs($target, keys %{$export_for{$caller}});
}
sub Dumper {
require Data::Dumper;
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Sortkeys = 0;
local $Data::Dumper::Quotekeys = 0;
local $Data::Dumper::Terse = 1;
Data::Dumper::Dumper(@_)
}
BEGIN {
if ($] >= 5.010) {
{ local $@; require mro; }
}
else {
local $@;
eval {
require MRO::Compat;
} or do {
*mro::get_linear_isa = *mro::get_linear_isa_dfs = sub {
no strict 'refs';
my $classname = shift;
my @lin = ($classname);
my %stored;
foreach my $parent (@{"$classname\::ISA"}) {
my $plin = mro::get_linear_isa_dfs($parent);
foreach (@$plin) {
next if exists $stored{$_};
push(@lin, $_);
$stored{$_} = 1;
}
}
return \@lin;
};
}
}
}
sub override {
my ($methods, $code) = @_;
my $caller = scalar caller;
for my $method ( ref($methods) ? @$methods : $methods ) {
my $full_method = "${caller}::${method}";
*{_glob_for $full_method} = $code;
}
}
}
1;
}
# ###########################################################################
# End Lmo package
# ###########################################################################
# ###########################################################################
# VersionParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionParser.pm
# t/lib/VersionParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionParser;
use Lmo;
use Scalar::Util qw(blessed);
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use overload (
'""' => "version",
'<=>' => "cmp",
'cmp' => "cmp",
fallback => 1,
);
use Carp ();
has major => (
is => 'ro',
isa => 'Int',
required => 1,
);
has [qw( minor revision )] => (
is => 'ro',
isa => 'Num',
);
has flavor => (
is => 'ro',
isa => 'Str',
default => sub { 'Unknown' },
);
has innodb_version => (
is => 'ro',
isa => 'Str',
default => sub { 'NO' },
);
sub series {
my $self = shift;
return $self->_join_version($self->major, $self->minor);
}
sub version {
my $self = shift;
return $self->_join_version($self->major, $self->minor, $self->revision);
}
sub is_in {
my ($self, $target) = @_;
return $self eq $target;
}
sub _join_version {
my ($self, @parts) = @_;
return join ".", map { my $c = $_; $c =~ s/^0\./0/; $c } grep defined, @parts;
}
sub _split_version {
my ($self, $str) = @_;
my @version_parts = map { s/^0(?=\d)/0./; $_ } $str =~ m/(\d+)/g;
return @version_parts[0..2];
}
sub normalized_version {
my ( $self ) = @_;
my $result = sprintf('%d%02d%02d', map { $_ || 0 } $self->major,
$self->minor,
$self->revision);
PTDEBUG && _d($self->version, 'normalizes to', $result);
return $result;
}
sub comment {
my ( $self, $cmd ) = @_;
my $v = $self->normalized_version();
return "/*!$v $cmd */"
}
my @methods = qw(major minor revision);
sub cmp {
my ($left, $right) = @_;
my $right_obj = (blessed($right) && $right->isa(ref($left)))
? $right
: ref($left)->new($right);
my $retval = 0;
for my $m ( @methods ) {
last unless defined($left->$m) && defined($right_obj->$m);
$retval = $left->$m <=> $right_obj->$m;
last if $retval;
}
return $retval;
}
sub BUILDARGS {
my $self = shift;
if ( @_ == 1 ) {
my %args;
if ( blessed($_[0]) && $_[0]->can("selectrow_hashref") ) {
PTDEBUG && _d("VersionParser got a dbh, trying to get the version");
my $dbh = $_[0];
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $query = eval {
$dbh->selectall_arrayref(q/SHOW VARIABLES LIKE 'version%'/, { Slice => {} })
};
if ( $query ) {
$query = { map { $_->{variable_name} => $_->{value} } @$query };
@args{@methods} = $self->_split_version($query->{version});
$args{flavor} = delete $query->{version_comment}
if $query->{version_comment};
}
elsif ( eval { ($query) = $dbh->selectrow_array(q/SELECT VERSION()/) } ) {
@args{@methods} = $self->_split_version($query);
}
else {
Carp::confess("Couldn't get the version from the dbh while "
. "creating a VersionParser object: $@");
}
$args{innodb_version} = eval { $self->_innodb_version($dbh) };
}
elsif ( !ref($_[0]) ) {
@args{@methods} = $self->_split_version($_[0]);
}
for my $method (@methods) {
delete $args{$method} unless defined $args{$method};
}
@_ = %args if %args;
}
return $self->SUPER::BUILDARGS(@_);
}
sub _innodb_version {
my ( $self, $dbh ) = @_;
return unless $dbh;
my $innodb_version = "NO";
my ($innodb) =
grep { $_->{engine} =~ m/InnoDB/i }
map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{ $dbh->selectall_arrayref("SHOW ENGINES", {Slice=>{}}) };
if ( $innodb ) {
PTDEBUG && _d("InnoDB support:", $innodb->{support});
if ( $innodb->{support} =~ m/YES|DEFAULT/i ) {
my $vars = $dbh->selectrow_hashref(
"SHOW VARIABLES LIKE 'innodb_version'");
$innodb_version = !$vars ? "BUILTIN"
: ($vars->{Value} || $vars->{value});
}
else {
$innodb_version = $innodb->{support}; # probably DISABLED or NO
}
}
PTDEBUG && _d("InnoDB version:", $innodb_version);
return $innodb_version;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
no Lmo;
1;
}
# ###########################################################################
# End VersionParser package
# ###########################################################################
# ###########################################################################
# DSNParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/DSNParser.pm
# t/lib/DSNParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package DSNParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 0;
$Data::Dumper::Quotekeys = 0;
my $dsn_sep = qr/(? {} # h, P, u, etc. Should come from DSN OPTIONS section in POD.
};
foreach my $opt ( @{$args{opts}} ) {
if ( !$opt->{key} || !$opt->{desc} ) {
die "Invalid DSN option: ", Dumper($opt);
}
PTDEBUG && _d('DSN option:',
join(', ',
map { "$_=" . (defined $opt->{$_} ? ($opt->{$_} || '') : 'undef') }
keys %$opt
)
);
$self->{opts}->{$opt->{key}} = {
dsn => $opt->{dsn},
desc => $opt->{desc},
copy => $opt->{copy} || 0,
};
}
return bless $self, $class;
}
sub prop {
my ( $self, $prop, $value ) = @_;
if ( @_ > 2 ) {
PTDEBUG && _d('Setting', $prop, 'property');
$self->{$prop} = $value;
}
return $self->{$prop};
}
sub parse {
my ( $self, $dsn, $prev, $defaults ) = @_;
if ( !$dsn ) {
PTDEBUG && _d('No DSN to parse');
return;
}
PTDEBUG && _d('Parsing', $dsn);
$prev ||= {};
$defaults ||= {};
my %given_props;
my %final_props;
my $opts = $self->{opts};
foreach my $dsn_part ( split($dsn_sep, $dsn) ) {
$dsn_part =~ s/\\,/,/g;
if ( my ($prop_key, $prop_val) = $dsn_part =~ m/^(.)=(.*)$/ ) {
$given_props{$prop_key} = $prop_val;
}
else {
PTDEBUG && _d('Interpreting', $dsn_part, 'as h=', $dsn_part);
$given_props{h} = $dsn_part;
}
}
foreach my $key ( keys %$opts ) {
PTDEBUG && _d('Finding value for', $key);
$final_props{$key} = $given_props{$key};
if ( !defined $final_props{$key}
&& defined $prev->{$key} && $opts->{$key}->{copy} )
{
$final_props{$key} = $prev->{$key};
PTDEBUG && _d('Copying value for', $key, 'from previous DSN');
}
if ( !defined $final_props{$key} ) {
$final_props{$key} = $defaults->{$key};
PTDEBUG && _d('Copying value for', $key, 'from defaults');
}
}
foreach my $key ( keys %given_props ) {
die "Unknown DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless exists $opts->{$key};
}
if ( (my $required = $self->prop('required')) ) {
foreach my $key ( keys %$required ) {
die "Missing required DSN option '$key' in '$dsn'. For more details, "
. "please use the --help option, or try 'perldoc $PROGRAM_NAME' "
. "for complete documentation."
unless $final_props{$key};
}
}
return \%final_props;
}
sub parse_options {
my ( $self, $o ) = @_;
die 'I need an OptionParser object' unless ref $o eq 'OptionParser';
my $dsn_string
= join(',',
map { "$_=".$o->get($_); }
grep { $o->has($_) && $o->get($_) }
keys %{$self->{opts}}
);
PTDEBUG && _d('DSN string made from options:', $dsn_string);
return $self->parse($dsn_string);
}
sub as_string {
my ( $self, $dsn, $props ) = @_;
return $dsn unless ref $dsn;
my @keys = $props ? @$props : sort keys %$dsn;
return join(',',
map { "$_=" . ($_ eq 'p' ? '...' : $dsn->{$_}) }
grep {
exists $self->{opts}->{$_}
&& exists $dsn->{$_}
&& defined $dsn->{$_}
} @keys);
}
sub usage {
my ( $self ) = @_;
my $usage
= "DSN syntax is key=value[,key=value...] Allowable DSN keys:\n\n"
. " KEY COPY MEANING\n"
. " === ==== =============================================\n";
my %opts = %{$self->{opts}};
foreach my $key ( sort keys %opts ) {
$usage .= " $key "
. ($opts{$key}->{copy} ? 'yes ' : 'no ')
. ($opts{$key}->{desc} || '[No description]')
. "\n";
}
$usage .= "\n If the DSN is a bareword, the word is treated as the 'h' key.\n";
return $usage;
}
sub get_cxn_params {
my ( $self, $info ) = @_;
my $dsn;
my %opts = %{$self->{opts}};
my $driver = $self->prop('dbidriver') || '';
if ( $driver eq 'Pg' ) {
$dsn = 'DBI:Pg:dbname=' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(h P));
}
else {
$dsn = 'DBI:mysql:' . ( $info->{D} || '' ) . ';'
. join(';', map { "$opts{$_}->{dsn}=$info->{$_}" }
grep { defined $info->{$_} }
qw(F h P S A))
. ';mysql_read_default_group=client'
. ($info->{L} ? ';mysql_local_infile=1' : '');
}
PTDEBUG && _d($dsn);
return ($dsn, $info->{u}, $info->{p});
}
sub fill_in_dsn {
my ( $self, $dbh, $dsn ) = @_;
my $vars = $dbh->selectall_hashref('SHOW VARIABLES', 'Variable_name');
my ($user, $db) = $dbh->selectrow_array('SELECT USER(), DATABASE()');
$user =~ s/@.*//;
$dsn->{h} ||= $vars->{hostname}->{Value};
$dsn->{S} ||= $vars->{'socket'}->{Value};
$dsn->{P} ||= $vars->{port}->{Value};
$dsn->{u} ||= $user;
$dsn->{D} ||= $db;
}
sub get_dbh {
my ( $self, $cxn_string, $user, $pass, $opts ) = @_;
$opts ||= {};
my $defaults = {
AutoCommit => 0,
RaiseError => 1,
PrintError => 0,
ShowErrorStatement => 1,
mysql_enable_utf8 => ($cxn_string =~ m/charset=utf8/i ? 1 : 0),
};
@{$defaults}{ keys %$opts } = values %$opts;
if (delete $defaults->{L}) { # L for LOAD DATA LOCAL INFILE, our own extension
$defaults->{mysql_local_infile} = 1;
}
if ( $opts->{mysql_use_result} ) {
$defaults->{mysql_use_result} = 1;
}
if ( !$have_dbi ) {
die "Cannot connect to MySQL because the Perl DBI module is not "
. "installed or not found. Run 'perl -MDBI' to see the directories "
. "that Perl searches for DBI. If DBI is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbi-perl\n"
. " RHEL/CentOS yum install perl-DBI\n"
. " OpenSolaris pkg install pkg:/SUNWpmdbi\n";
}
my $dbh;
my $tries = 2;
while ( !$dbh && $tries-- ) {
PTDEBUG && _d($cxn_string, ' ', $user, ' ', $pass,
join(', ', map { "$_=>$defaults->{$_}" } keys %$defaults ));
$dbh = eval { DBI->connect($cxn_string, $user, $pass, $defaults) };
if ( !$dbh && $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/locate DBD\/mysql/i ) {
die "Cannot connect to MySQL because the Perl DBD::mysql module is "
. "not installed or not found. Run 'perl -MDBD::mysql' to see "
. "the directories that Perl searches for DBD::mysql. If "
. "DBD::mysql is not installed, try:\n"
. " Debian/Ubuntu apt-get install libdbd-mysql-perl\n"
. " RHEL/CentOS yum install perl-DBD-MySQL\n"
. " OpenSolaris pgk install pkg:/SUNWapu13dbd-mysql\n";
}
elsif ( $EVAL_ERROR =~ m/not a compiled character set|character set utf8/ ) {
PTDEBUG && _d('Going to try again without utf8 support');
delete $defaults->{mysql_enable_utf8};
}
if ( !$tries ) {
die $EVAL_ERROR;
}
}
}
if ( $cxn_string =~ m/mysql/i ) {
my $sql;
$sql = 'SELECT @@SQL_MODE';
PTDEBUG && _d($dbh, $sql);
my ($sql_mode) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
die "Error getting the current SQL_MODE: $EVAL_ERROR";
}
if ( my ($charset) = $cxn_string =~ m/charset=([\w]+)/ ) {
$sql = qq{/*!40101 SET NAMES "$charset"*/};
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting NAMES to $charset: $EVAL_ERROR";
}
PTDEBUG && _d('Enabling charset for STDOUT');
if ( $charset eq 'utf8' ) {
binmode(STDOUT, ':utf8')
or die "Can't binmode(STDOUT, ':utf8'): $OS_ERROR";
}
else {
binmode(STDOUT) or die "Can't binmode(STDOUT): $OS_ERROR";
}
}
if ( my $vars = $self->prop('set-vars') ) {
$self->set_vars($dbh, $vars);
}
$sql = 'SET @@SQL_QUOTE_SHOW_CREATE = 1'
. '/*!40101, @@SQL_MODE=\'NO_AUTO_VALUE_ON_ZERO'
. ($sql_mode ? ",$sql_mode" : '')
. '\'*/';
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( $EVAL_ERROR ) {
die "Error setting SQL_QUOTE_SHOW_CREATE, SQL_MODE"
. ($sql_mode ? " and $sql_mode" : '')
. ": $EVAL_ERROR";
}
}
PTDEBUG && _d('DBH info: ',
$dbh,
Dumper($dbh->selectrow_hashref(
'SELECT DATABASE(), CONNECTION_ID(), VERSION()/*!50038 , @@hostname*/')),
'Connection info:', $dbh->{mysql_hostinfo},
'Character set info:', Dumper($dbh->selectall_arrayref(
"SHOW VARIABLES LIKE 'character_set%'", { Slice => {}})),
'$DBD::mysql::VERSION:', $DBD::mysql::VERSION,
'$DBI::VERSION:', $DBI::VERSION,
);
return $dbh;
}
sub get_hostname {
my ( $self, $dbh ) = @_;
if ( my ($host) = ($dbh->{mysql_hostinfo} || '') =~ m/^(\w+) via/ ) {
return $host;
}
my ( $hostname, $one ) = $dbh->selectrow_array(
'SELECT /*!50038 @@hostname, */ 1');
return $hostname;
}
sub disconnect {
my ( $self, $dbh ) = @_;
PTDEBUG && $self->print_active_handles($dbh);
$dbh->disconnect;
}
sub print_active_handles {
my ( $self, $thing, $level ) = @_;
$level ||= 0;
printf("# Active %sh: %s %s %s\n", ($thing->{Type} || 'undef'), "\t" x $level,
$thing, (($thing->{Type} || '') eq 'st' ? $thing->{Statement} || '' : ''))
or die "Cannot print: $OS_ERROR";
foreach my $handle ( grep {defined} @{ $thing->{ChildHandles} } ) {
$self->print_active_handles( $handle, $level + 1 );
}
}
sub copy {
my ( $self, $dsn_1, $dsn_2, %args ) = @_;
die 'I need a dsn_1 argument' unless $dsn_1;
die 'I need a dsn_2 argument' unless $dsn_2;
my %new_dsn = map {
my $key = $_;
my $val;
if ( $args{overwrite} ) {
$val = defined $dsn_1->{$key} ? $dsn_1->{$key} : $dsn_2->{$key};
}
else {
$val = defined $dsn_2->{$key} ? $dsn_2->{$key} : $dsn_1->{$key};
}
$key => $val;
} keys %{$self->{opts}};
return \%new_dsn;
}
sub set_vars {
my ($self, $dbh, $vars) = @_;
return unless $vars;
foreach my $var ( sort keys %$vars ) {
my $val = $vars->{$var}->{val};
(my $quoted_var = $var) =~ s/_/\\_/;
my ($var_exists, $current_val);
eval {
($var_exists, $current_val) = $dbh->selectrow_array(
"SHOW VARIABLES LIKE '$quoted_var'");
};
my $e = $EVAL_ERROR;
if ( $e ) {
PTDEBUG && _d($e);
}
if ( $vars->{$var}->{default} && !$var_exists ) {
PTDEBUG && _d('Not setting default var', $var,
'because it does not exist');
next;
}
if ( $current_val && $current_val eq $val ) {
PTDEBUG && _d('Not setting var', $var, 'because its value',
'is already', $val);
next;
}
my $sql = "SET SESSION $var=$val";
PTDEBUG && _d($dbh, $sql);
eval { $dbh->do($sql) };
if ( my $set_error = $EVAL_ERROR ) {
chomp($set_error);
$set_error =~ s/ at \S+ line \d+//;
my $msg = "Error setting $var: $set_error";
if ( $current_val ) {
$msg .= " The current value for $var is $current_val. "
. "If the variable is read only (not dynamic), specify "
. "--set-vars $var=$current_val to avoid this warning, "
. "else manually set the variable and restart MySQL.";
}
warn $msg . "\n\n";
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End DSNParser package
# ###########################################################################
# ###########################################################################
# Daemon package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Daemon.pm
# t/lib/Daemon.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Daemon;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use POSIX qw(setsid);
use Fcntl qw(:DEFAULT);
sub new {
my ($class, %args) = @_;
my $self = {
log_file => $args{log_file},
pid_file => $args{pid_file},
daemonize => $args{daemonize},
force_log_file => $args{force_log_file},
parent_exit => $args{parent_exit},
pid_file_owner => 0,
};
return bless $self, $class;
}
sub run {
my ($self) = @_;
my $daemonize = $self->{daemonize};
my $pid_file = $self->{pid_file};
my $log_file = $self->{log_file};
my $force_log_file = $self->{force_log_file};
my $parent_exit = $self->{parent_exit};
PTDEBUG && _d('Starting daemon');
if ( $pid_file ) {
eval {
$self->_make_pid_file(
pid => $PID, # parent's pid
pid_file => $pid_file,
);
};
die "$EVAL_ERROR\n" if $EVAL_ERROR;
if ( !$daemonize ) {
$self->{pid_file_owner} = $PID; # parent's pid
}
}
if ( $daemonize ) {
defined (my $child_pid = fork()) or die "Cannot fork: $OS_ERROR";
if ( $child_pid ) {
PTDEBUG && _d('Forked child', $child_pid);
$parent_exit->($child_pid) if $parent_exit;
exit 0;
}
POSIX::setsid() or die "Cannot start a new session: $OS_ERROR";
chdir '/' or die "Cannot chdir to /: $OS_ERROR";
if ( $pid_file ) {
$self->_update_pid_file(
pid => $PID, # child's pid
pid_file => $pid_file,
);
$self->{pid_file_owner} = $PID;
}
}
if ( $daemonize || $force_log_file ) {
PTDEBUG && _d('Redirecting STDIN to /dev/null');
close STDIN;
open STDIN, '/dev/null'
or die "Cannot reopen STDIN to /dev/null: $OS_ERROR";
if ( $log_file ) {
PTDEBUG && _d('Redirecting STDOUT and STDERR to', $log_file);
close STDOUT;
open STDOUT, '>>', $log_file
or die "Cannot open log file $log_file: $OS_ERROR";
close STDERR;
open STDERR, ">&STDOUT"
or die "Cannot dupe STDERR to STDOUT: $OS_ERROR";
}
else {
if ( -t STDOUT ) {
PTDEBUG && _d('No log file and STDOUT is a terminal;',
'redirecting to /dev/null');
close STDOUT;
open STDOUT, '>', '/dev/null'
or die "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
if ( -t STDERR ) {
PTDEBUG && _d('No log file and STDERR is a terminal;',
'redirecting to /dev/null');
close STDERR;
open STDERR, '>', '/dev/null'
or die "Cannot reopen STDERR to /dev/null: $OS_ERROR";
}
}
$OUTPUT_AUTOFLUSH = 1;
}
PTDEBUG && _d('Daemon running');
return;
}
sub _make_pid_file {
my ($self, %args) = @_;
my @required_args = qw(pid pid_file);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my $pid = $args{pid};
my $pid_file = $args{pid_file};
eval {
sysopen(PID_FH, $pid_file, O_RDWR|O_CREAT|O_EXCL) or die $OS_ERROR;
print PID_FH $PID, "\n";
close PID_FH;
};
if ( my $e = $EVAL_ERROR ) {
if ( $e =~ m/file exists/i ) {
my $old_pid = $self->_check_pid_file(
pid_file => $pid_file,
pid => $PID,
);
if ( $old_pid ) {
warn "Overwriting PID file $pid_file because PID $old_pid "
. "is not running.\n";
}
$self->_update_pid_file(
pid => $PID,
pid_file => $pid_file
);
}
else {
die "Error creating PID file $pid_file: $e\n";
}
}
return;
}
sub _check_pid_file {
my ($self, %args) = @_;
my @required_args = qw(pid_file pid);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my $pid_file = $args{pid_file};
my $pid = $args{pid};
PTDEBUG && _d('Checking if PID in', $pid_file, 'is running');
if ( ! -f $pid_file ) {
PTDEBUG && _d('PID file', $pid_file, 'does not exist');
return;
}
open my $fh, '<', $pid_file
or die "Error opening $pid_file: $OS_ERROR";
my $existing_pid = do { local $/; <$fh> };
chomp($existing_pid) if $existing_pid;
close $fh
or die "Error closing $pid_file: $OS_ERROR";
if ( $existing_pid ) {
if ( $existing_pid == $pid ) {
warn "The current PID $pid already holds the PID file $pid_file\n";
return;
}
else {
PTDEBUG && _d('Checking if PID', $existing_pid, 'is running');
my $pid_is_alive = kill 0, $existing_pid;
if ( $pid_is_alive ) {
die "PID file $pid_file exists and PID $existing_pid is running\n";
}
}
}
else {
die "PID file $pid_file exists but it is empty. Remove the file "
. "if the process is no longer running.\n";
}
return $existing_pid;
}
sub _update_pid_file {
my ($self, %args) = @_;
my @required_args = qw(pid pid_file);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my $pid = $args{pid};
my $pid_file = $args{pid_file};
open my $fh, '>', $pid_file
or die "Cannot open $pid_file: $OS_ERROR";
print { $fh } $pid, "\n"
or die "Cannot print to $pid_file: $OS_ERROR";
close $fh
or warn "Cannot close $pid_file: $OS_ERROR";
return;
}
sub remove_pid_file {
my ($self, $pid_file) = @_;
$pid_file ||= $self->{pid_file};
if ( $pid_file && -f $pid_file ) {
unlink $self->{pid_file}
or warn "Cannot remove PID file $pid_file: $OS_ERROR";
PTDEBUG && _d('Removed PID file');
}
else {
PTDEBUG && _d('No PID to remove');
}
return;
}
sub DESTROY {
my ($self) = @_;
if ( $self->{pid_file_owner} == $PID ) {
$self->remove_pid_file();
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Daemon package
# ###########################################################################
# ###########################################################################
# Quoter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Quoter.pm
# t/lib/Quoter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Quoter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
return bless {}, $class;
}
sub quote {
my ( $self, @vals ) = @_;
foreach my $val ( @vals ) {
$val =~ s/`/``/g;
}
return join('.', map { '`' . $_ . '`' } @vals);
}
sub quote_val {
my ( $self, $val, %args ) = @_;
return 'NULL' unless defined $val; # undef = NULL
return "''" if $val eq ''; # blank string = ''
return $val if $val =~ m/^0x[0-9a-fA-F]+$/ # quote hex data
&& !$args{is_char}; # unless is_char is true
return $val if $args{is_float};
$val =~ s/(['\\])/\\$1/g;
return "'$val'";
}
sub split_unquote {
my ( $self, $db_tbl, $default_db ) = @_;
my ( $db, $tbl ) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
for ($db, $tbl) {
next unless $_;
s/\A`//;
s/`\z//;
s/``/`/g;
}
return ($db, $tbl);
}
sub literal_like {
my ( $self, $like ) = @_;
return unless $like;
$like =~ s/([%_])/\\$1/g;
return "'$like'";
}
sub join_quote {
my ( $self, $default_db, $db_tbl ) = @_;
return unless $db_tbl;
my ($db, $tbl) = split(/[.]/, $db_tbl);
if ( !$tbl ) {
$tbl = $db;
$db = $default_db;
}
$db = "`$db`" if $db && $db !~ m/^`/;
$tbl = "`$tbl`" if $tbl && $tbl !~ m/^`/;
return $db ? "$db.$tbl" : $tbl;
}
sub serialize_list {
my ( $self, @args ) = @_;
PTDEBUG && _d('Serializing', Dumper(\@args));
return unless @args;
my @parts;
foreach my $arg ( @args ) {
if ( defined $arg ) {
$arg =~ s/,/\\,/g; # escape commas
$arg =~ s/\\N/\\\\N/g; # escape literal \N
push @parts, $arg;
}
else {
push @parts, '\N';
}
}
my $string = join(',', @parts);
PTDEBUG && _d('Serialized: <', $string, '>');
return $string;
}
sub deserialize_list {
my ( $self, $string ) = @_;
PTDEBUG && _d('Deserializing <', $string, '>');
die "Cannot deserialize an undefined string" unless defined $string;
my @parts;
foreach my $arg ( split(/(? 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(TableParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = { %args };
return bless $self, $class;
}
sub generate_asc_stmt {
my ( $self, %args ) = @_;
my @required_args = qw(tbl_struct index);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($tbl_struct, $index) = @args{@required_args};
my @cols = $args{cols} ? @{$args{cols}} : @{$tbl_struct->{cols}};
my $q = $self->{Quoter};
die "Index '$index' does not exist in table"
unless exists $tbl_struct->{keys}->{$index};
PTDEBUG && _d('Will ascend index', $index);
my @asc_cols = @{$tbl_struct->{keys}->{$index}->{cols}};
if ( $args{asc_first} ) {
PTDEBUG && _d('Ascending only first column');
@asc_cols = $asc_cols[0];
}
elsif ( my $n = $args{n_index_cols} ) {
$n = scalar @asc_cols if $n > @asc_cols;
PTDEBUG && _d('Ascending only first', $n, 'columns');
@asc_cols = @asc_cols[0..($n-1)];
}
PTDEBUG && _d('Will ascend columns', join(', ', @asc_cols));
my @asc_slice;
my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
foreach my $col ( @asc_cols ) {
if ( !exists $col_posn{$col} ) {
push @cols, $col;
$col_posn{$col} = $#cols;
}
push @asc_slice, $col_posn{$col};
}
PTDEBUG && _d('Will ascend, in ordinal position:', join(', ', @asc_slice));
my $asc_stmt = {
cols => \@cols,
index => $index,
where => '',
slice => [],
scols => [],
};
if ( @asc_slice ) {
my $cmp_where;
foreach my $cmp ( qw(< <= >= >) ) {
$cmp_where = $self->generate_cmp_where(
type => $cmp,
slice => \@asc_slice,
cols => \@cols,
quoter => $q,
is_nullable => $tbl_struct->{is_nullable},
);
$asc_stmt->{boundaries}->{$cmp} = $cmp_where->{where};
}
my $cmp = $args{asc_only} ? '>' : '>=';
$asc_stmt->{where} = $asc_stmt->{boundaries}->{$cmp};
$asc_stmt->{slice} = $cmp_where->{slice};
$asc_stmt->{scols} = $cmp_where->{scols};
}
return $asc_stmt;
}
sub generate_cmp_where {
my ( $self, %args ) = @_;
foreach my $arg ( qw(type slice cols is_nullable) ) {
die "I need a $arg arg" unless defined $args{$arg};
}
my @slice = @{$args{slice}};
my @cols = @{$args{cols}};
my $is_nullable = $args{is_nullable};
my $type = $args{type};
my $q = $self->{Quoter};
(my $cmp = $type) =~ s/=//;
my @r_slice; # Resulting slice columns, by ordinal
my @r_scols; # Ditto, by name
my @clauses;
foreach my $i ( 0 .. $#slice ) {
my @clause;
foreach my $j ( 0 .. $i - 1 ) {
my $ord = $slice[$j];
my $col = $cols[$ord];
my $quo = $q->quote($col);
if ( $is_nullable->{$col} ) {
push @clause, "((? IS NULL AND $quo IS NULL) OR ($quo = ?))";
push @r_slice, $ord, $ord;
push @r_scols, $col, $col;
}
else {
push @clause, "$quo = ?";
push @r_slice, $ord;
push @r_scols, $col;
}
}
my $ord = $slice[$i];
my $col = $cols[$ord];
my $quo = $q->quote($col);
my $end = $i == $#slice; # Last clause of the whole group.
if ( $is_nullable->{$col} ) {
if ( $type =~ m/=/ && $end ) {
push @clause, "(? IS NULL OR $quo $type ?)";
}
elsif ( $type =~ m/>/ ) {
push @clause, "((? IS NULL AND $quo IS NOT NULL) OR ($quo $cmp ?))";
}
else { # If $type =~ m/ \@r_slice,
scols => \@r_scols,
where => $result,
};
return $where;
}
sub generate_del_stmt {
my ( $self, %args ) = @_;
my $tbl = $args{tbl_struct};
my @cols = $args{cols} ? @{$args{cols}} : ();
my $tp = $self->{TableParser};
my $q = $self->{Quoter};
my @del_cols;
my @del_slice;
my $index = $tp->find_best_index($tbl, $args{index});
die "Cannot find an ascendable index in table" unless $index;
if ( $index ) {
@del_cols = @{$tbl->{keys}->{$index}->{cols}};
}
else {
@del_cols = @{$tbl->{cols}};
}
PTDEBUG && _d('Columns needed for DELETE:', join(', ', @del_cols));
my %col_posn = do { my $i = 0; map { $_ => $i++ } @cols };
foreach my $col ( @del_cols ) {
if ( !exists $col_posn{$col} ) {
push @cols, $col;
$col_posn{$col} = $#cols;
}
push @del_slice, $col_posn{$col};
}
PTDEBUG && _d('Ordinals needed for DELETE:', join(', ', @del_slice));
my $del_stmt = {
cols => \@cols,
index => $index,
where => '',
slice => [],
scols => [],
};
my @clauses;
foreach my $i ( 0 .. $#del_slice ) {
my $ord = $del_slice[$i];
my $col = $cols[$ord];
my $quo = $q->quote($col);
if ( $tbl->{is_nullable}->{$col} ) {
push @clauses, "((? IS NULL AND $quo IS NULL) OR ($quo = ?))";
push @{$del_stmt->{slice}}, $ord, $ord;
push @{$del_stmt->{scols}}, $col, $col;
}
else {
push @clauses, "$quo = ?";
push @{$del_stmt->{slice}}, $ord;
push @{$del_stmt->{scols}}, $col;
}
}
$del_stmt->{where} = '(' . join(' AND ', @clauses) . ')';
return $del_stmt;
}
sub generate_ins_stmt {
my ( $self, %args ) = @_;
foreach my $arg ( qw(ins_tbl sel_cols) ) {
die "I need a $arg argument" unless $args{$arg};
}
my $ins_tbl = $args{ins_tbl};
my @sel_cols = @{$args{sel_cols}};
die "You didn't specify any SELECT columns" unless @sel_cols;
my @ins_cols;
my @ins_slice;
for my $i ( 0..$#sel_cols ) {
next unless $ins_tbl->{is_col}->{$sel_cols[$i]};
push @ins_cols, $sel_cols[$i];
push @ins_slice, $i;
}
return {
cols => \@ins_cols,
slice => \@ins_slice,
};
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TableNibbler package
# ###########################################################################
# ###########################################################################
# TableParser package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/TableParser.pm
# t/lib/TableParser.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package TableParser;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
local $EVAL_ERROR;
eval {
require Quoter;
};
sub new {
my ( $class, %args ) = @_;
my $self = { %args };
$self->{Quoter} ||= Quoter->new();
return bless $self, $class;
}
sub Quoter { shift->{Quoter} }
sub get_create_table {
my ( $self, $dbh, $db, $tbl ) = @_;
die "I need a dbh parameter" unless $dbh;
die "I need a db parameter" unless $db;
die "I need a tbl parameter" unless $tbl;
my $q = $self->{Quoter};
my $new_sql_mode
= q{/*!40101 SET @OLD_SQL_MODE := @@SQL_MODE, }
. q{@@SQL_MODE := '', }
. q{@OLD_QUOTE := @@SQL_QUOTE_SHOW_CREATE, }
. q{@@SQL_QUOTE_SHOW_CREATE := 1 */};
my $old_sql_mode
= q{/*!40101 SET @@SQL_MODE := @OLD_SQL_MODE, }
. q{@@SQL_QUOTE_SHOW_CREATE := @OLD_QUOTE */};
PTDEBUG && _d($new_sql_mode);
eval { $dbh->do($new_sql_mode); };
PTDEBUG && $EVAL_ERROR && _d($EVAL_ERROR);
my $use_sql = 'USE ' . $q->quote($db);
PTDEBUG && _d($dbh, $use_sql);
$dbh->do($use_sql);
my $show_sql = "SHOW CREATE TABLE " . $q->quote($db, $tbl);
PTDEBUG && _d($show_sql);
my $href;
eval { $href = $dbh->selectrow_hashref($show_sql); };
if ( my $e = $EVAL_ERROR ) {
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
die $e;
}
PTDEBUG && _d($old_sql_mode);
$dbh->do($old_sql_mode);
my ($key) = grep { m/create (?:table|view)/i } keys %$href;
if ( !$key ) {
die "Error: no 'Create Table' or 'Create View' in result set from "
. "$show_sql: " . Dumper($href);
}
return $href->{$key};
}
sub parse {
my ( $self, $ddl, $opts ) = @_;
return unless $ddl;
if ( $ddl =~ m/CREATE (?:TEMPORARY )?TABLE "/ ) {
$ddl = $self->ansi_to_legacy($ddl);
}
elsif ( $ddl !~ m/CREATE (?:TEMPORARY )?TABLE `/ ) {
die "TableParser doesn't handle CREATE TABLE without quoting.";
}
my ($name) = $ddl =~ m/CREATE (?:TEMPORARY )?TABLE\s+(`.+?`)/;
(undef, $name) = $self->{Quoter}->split_unquote($name) if $name;
$ddl =~ s/(`[^`]+`)/\L$1/g;
my $engine = $self->get_engine($ddl);
my @defs = $ddl =~ m/^(\s+`.*?),?$/gm;
my @cols = map { $_ =~ m/`([^`]+)`/ } @defs;
PTDEBUG && _d('Table cols:', join(', ', map { "`$_`" } @cols));
my %def_for;
@def_for{@cols} = @defs;
my (@nums, @null);
my (%type_for, %is_nullable, %is_numeric, %is_autoinc);
foreach my $col ( @cols ) {
my $def = $def_for{$col};
$def =~ s/``//g;
my ( $type ) = $def =~ m/`[^`]+`\s([a-z]+)/;
die "Can't determine column type for $def" unless $type;
$type_for{$col} = $type;
if ( $type =~ m/(?:(?:tiny|big|medium|small)?int|float|double|decimal|year)/ ) {
push @nums, $col;
$is_numeric{$col} = 1;
}
if ( $def !~ m/NOT NULL/ ) {
push @null, $col;
$is_nullable{$col} = 1;
}
$is_autoinc{$col} = $def =~ m/AUTO_INCREMENT/i ? 1 : 0;
}
my ($keys, $clustered_key) = $self->get_keys($ddl, $opts, \%is_nullable);
my ($charset) = $ddl =~ m/DEFAULT CHARSET=(\w+)/;
return {
name => $name,
cols => \@cols,
col_posn => { map { $cols[$_] => $_ } 0..$#cols },
is_col => { map { $_ => 1 } @cols },
null_cols => \@null,
is_nullable => \%is_nullable,
is_autoinc => \%is_autoinc,
clustered_key => $clustered_key,
keys => $keys,
defs => \%def_for,
numeric_cols => \@nums,
is_numeric => \%is_numeric,
engine => $engine,
type_for => \%type_for,
charset => $charset,
};
}
sub sort_indexes {
my ( $self, $tbl ) = @_;
my @indexes
= sort {
(($a ne 'PRIMARY') <=> ($b ne 'PRIMARY'))
|| ( !$tbl->{keys}->{$a}->{is_unique} <=> !$tbl->{keys}->{$b}->{is_unique} )
|| ( $tbl->{keys}->{$a}->{is_nullable} <=> $tbl->{keys}->{$b}->{is_nullable} )
|| ( scalar(@{$tbl->{keys}->{$a}->{cols}}) <=> scalar(@{$tbl->{keys}->{$b}->{cols}}) )
}
grep {
$tbl->{keys}->{$_}->{type} eq 'BTREE'
}
sort keys %{$tbl->{keys}};
PTDEBUG && _d('Indexes sorted best-first:', join(', ', @indexes));
return @indexes;
}
sub find_best_index {
my ( $self, $tbl, $index ) = @_;
my $best;
if ( $index ) {
($best) = grep { uc $_ eq uc $index } keys %{$tbl->{keys}};
}
if ( !$best ) {
if ( $index ) {
die "Index '$index' does not exist in table";
}
else {
($best) = $self->sort_indexes($tbl);
}
}
PTDEBUG && _d('Best index found is', $best);
return $best;
}
sub find_possible_keys {
my ( $self, $dbh, $database, $table, $quoter, $where ) = @_;
return () unless $where;
my $sql = 'EXPLAIN SELECT * FROM ' . $quoter->quote($database, $table)
. ' WHERE ' . $where;
PTDEBUG && _d($sql);
my $expl = $dbh->selectrow_hashref($sql);
$expl = { map { lc($_) => $expl->{$_} } keys %$expl };
if ( $expl->{possible_keys} ) {
PTDEBUG && _d('possible_keys =', $expl->{possible_keys});
my @candidates = split(',', $expl->{possible_keys});
my %possible = map { $_ => 1 } @candidates;
if ( $expl->{key} ) {
PTDEBUG && _d('MySQL chose', $expl->{key});
unshift @candidates, grep { $possible{$_} } split(',', $expl->{key});
PTDEBUG && _d('Before deduping:', join(', ', @candidates));
my %seen;
@candidates = grep { !$seen{$_}++ } @candidates;
}
PTDEBUG && _d('Final list:', join(', ', @candidates));
return @candidates;
}
else {
PTDEBUG && _d('No keys in possible_keys');
return ();
}
}
sub check_table {
my ( $self, %args ) = @_;
my @required_args = qw(dbh db tbl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $db, $tbl) = @args{@required_args};
my $q = $self->{Quoter} || 'Quoter';
my $db_tbl = $q->quote($db, $tbl);
PTDEBUG && _d('Checking', $db_tbl);
$self->{check_table_error} = undef;
my $sql = "SHOW TABLES FROM " . $q->quote($db)
. ' LIKE ' . $q->literal_like($tbl);
PTDEBUG && _d($sql);
my $row;
eval {
$row = $dbh->selectrow_arrayref($sql);
};
if ( my $e = $EVAL_ERROR ) {
PTDEBUG && _d($e);
$self->{check_table_error} = $e;
return 0;
}
if ( !$row->[0] || $row->[0] ne $tbl ) {
PTDEBUG && _d('Table does not exist');
return 0;
}
PTDEBUG && _d('Table', $db, $tbl, 'exists');
return 1;
}
sub get_engine {
my ( $self, $ddl, $opts ) = @_;
my ( $engine ) = $ddl =~ m/\).*?(?:ENGINE|TYPE)=(\w+)/;
PTDEBUG && _d('Storage engine:', $engine);
return $engine || undef;
}
sub get_keys {
my ( $self, $ddl, $opts, $is_nullable ) = @_;
my $engine = $self->get_engine($ddl);
my $keys = {};
my $clustered_key = undef;
KEY:
foreach my $key ( $ddl =~ m/^ ((?:[A-Z]+ )?KEY .*)$/gm ) {
next KEY if $key =~ m/FOREIGN/;
my $key_ddl = $key;
PTDEBUG && _d('Parsed key:', $key_ddl);
if ( !$engine || $engine !~ m/MEMORY|HEAP/ ) {
$key =~ s/USING HASH/USING BTREE/;
}
my ( $type, $cols ) = $key =~ m/(?:USING (\w+))? \((.+)\)/;
my ( $special ) = $key =~ m/(FULLTEXT|SPATIAL)/;
$type = $type || $special || 'BTREE';
my ($name) = $key =~ m/(PRIMARY|`[^`]*`)/;
my $unique = $key =~ m/PRIMARY|UNIQUE/ ? 1 : 0;
my @cols;
my @col_prefixes;
foreach my $col_def ( $cols =~ m/`[^`]+`(?:\(\d+\))?/g ) {
my ($name, $prefix) = $col_def =~ m/`([^`]+)`(?:\((\d+)\))?/;
push @cols, $name;
push @col_prefixes, $prefix;
}
$name =~ s/`//g;
PTDEBUG && _d( $name, 'key cols:', join(', ', map { "`$_`" } @cols));
$keys->{$name} = {
name => $name,
type => $type,
colnames => $cols,
cols => \@cols,
col_prefixes => \@col_prefixes,
is_unique => $unique,
is_nullable => scalar(grep { $is_nullable->{$_} } @cols),
is_col => { map { $_ => 1 } @cols },
ddl => $key_ddl,
};
if ( ($engine || '') =~ m/InnoDB/i && !$clustered_key ) {
my $this_key = $keys->{$name};
if ( $this_key->{name} eq 'PRIMARY' ) {
$clustered_key = 'PRIMARY';
}
elsif ( $this_key->{is_unique} && !$this_key->{is_nullable} ) {
$clustered_key = $this_key->{name};
}
PTDEBUG && $clustered_key && _d('This key is the clustered key');
}
}
return $keys, $clustered_key;
}
sub get_fks {
my ( $self, $ddl, $opts ) = @_;
my $q = $self->{Quoter};
my $fks = {};
foreach my $fk (
$ddl =~ m/CONSTRAINT .* FOREIGN KEY .* REFERENCES [^\)]*\)/mg )
{
my ( $name ) = $fk =~ m/CONSTRAINT `(.*?)`/;
my ( $cols ) = $fk =~ m/FOREIGN KEY \(([^\)]+)\)/;
my ( $parent, $parent_cols ) = $fk =~ m/REFERENCES (\S+) \(([^\)]+)\)/;
my ($db, $tbl) = $q->split_unquote($parent, $opts->{database});
my %parent_tbl = (tbl => $tbl);
$parent_tbl{db} = $db if $db;
if ( $parent !~ m/\./ && $opts->{database} ) {
$parent = $q->quote($opts->{database}) . ".$parent";
}
$fks->{$name} = {
name => $name,
colnames => $cols,
cols => [ map { s/[ `]+//g; $_; } split(',', $cols) ],
parent_tbl => \%parent_tbl,
parent_tblname => $parent,
parent_cols => [ map { s/[ `]+//g; $_; } split(',', $parent_cols) ],
parent_colnames=> $parent_cols,
ddl => $fk,
};
}
return $fks;
}
sub remove_auto_increment {
my ( $self, $ddl ) = @_;
$ddl =~ s/(^\).*?) AUTO_INCREMENT=\d+\b/$1/m;
return $ddl;
}
sub get_table_status {
my ( $self, $dbh, $db, $like ) = @_;
my $q = $self->{Quoter};
my $sql = "SHOW TABLE STATUS FROM " . $q->quote($db);
my @params;
if ( $like ) {
$sql .= ' LIKE ?';
push @params, $like;
}
PTDEBUG && _d($sql, @params);
my $sth = $dbh->prepare($sql);
eval { $sth->execute(@params); };
if ($EVAL_ERROR) {
PTDEBUG && _d($EVAL_ERROR);
return;
}
my @tables = @{$sth->fetchall_arrayref({})};
@tables = map {
my %tbl; # Make a copy with lowercased keys
@tbl{ map { lc $_ } keys %$_ } = values %$_;
$tbl{engine} ||= $tbl{type} || $tbl{comment};
delete $tbl{type};
\%tbl;
} @tables;
return @tables;
}
my $ansi_quote_re = qr/" [^"]* (?: "" [^"]* )* (?<=.) "/ismx;
sub ansi_to_legacy {
my ($self, $ddl) = @_;
$ddl =~ s/($ansi_quote_re)/ansi_quote_replace($1)/ge;
return $ddl;
}
sub ansi_quote_replace {
my ($val) = @_;
$val =~ s/^"|"$//g;
$val =~ s/`/``/g;
$val =~ s/""/"/g;
return "`$val`";
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End TableParser package
# ###########################################################################
# ###########################################################################
# Progress package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Progress.pm
# t/lib/Progress.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Progress;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
foreach my $arg (qw(jobsize)) {
die "I need a $arg argument" unless defined $args{$arg};
}
if ( (!$args{report} || !$args{interval}) ) {
if ( $args{spec} && @{$args{spec}} == 2 ) {
@args{qw(report interval)} = @{$args{spec}};
}
else {
die "I need either report and interval arguments, or a spec";
}
}
my $name = $args{name} || "Progress";
$args{start} ||= time();
my $self;
$self = {
last_reported => $args{start},
fraction => 0, # How complete the job is
callback => sub {
my ($fraction, $elapsed, $remaining, $eta) = @_;
printf STDERR "$name: %3d%% %s remain\n",
$fraction * 100,
Transformers::secs_to_time($remaining),
Transformers::ts($eta);
},
%args,
};
return bless $self, $class;
}
sub validate_spec {
shift @_ if $_[0] eq 'Progress'; # Permit calling as Progress-> or Progress::
my ( $spec ) = @_;
if ( @$spec != 2 ) {
die "spec array requires a two-part argument\n";
}
if ( $spec->[0] !~ m/^(?:percentage|time|iterations)$/ ) {
die "spec array's first element must be one of "
. "percentage,time,iterations\n";
}
if ( $spec->[1] !~ m/^\d+$/ ) {
die "spec array's second element must be an integer\n";
}
}
sub set_callback {
my ( $self, $callback ) = @_;
$self->{callback} = $callback;
}
sub start {
my ( $self, $start ) = @_;
$self->{start} = $self->{last_reported} = $start || time();
$self->{first_report} = 0;
}
sub update {
my ( $self, $callback, %args ) = @_;
my $jobsize = $self->{jobsize};
my $now ||= $args{now} || time;
$self->{iterations}++; # How many updates have happened;
if ( !$self->{first_report} && $args{first_report} ) {
$args{first_report}->();
$self->{first_report} = 1;
}
if ( $self->{report} eq 'time'
&& $self->{interval} > $now - $self->{last_reported}
) {
return;
}
elsif ( $self->{report} eq 'iterations'
&& ($self->{iterations} - 1) % $self->{interval} > 0
) {
return;
}
$self->{last_reported} = $now;
my $completed = $callback->();
$self->{updates}++; # How many times we have run the update callback
return if $completed > $jobsize;
my $fraction = $completed > 0 ? $completed / $jobsize : 0;
if ( $self->{report} eq 'percentage'
&& $self->fraction_modulo($self->{fraction})
>= $self->fraction_modulo($fraction)
) {
$self->{fraction} = $fraction;
return;
}
$self->{fraction} = $fraction;
my $elapsed = $now - $self->{start};
my $remaining = 0;
my $eta = $now;
if ( $completed > 0 && $completed <= $jobsize && $elapsed > 0 ) {
my $rate = $completed / $elapsed;
if ( $rate > 0 ) {
$remaining = ($jobsize - $completed) / $rate;
$eta = $now + int($remaining);
}
}
$self->{callback}->($fraction, $elapsed, $remaining, $eta, $completed);
}
sub fraction_modulo {
my ( $self, $num ) = @_;
$num *= 100; # Convert from fraction to percentage
return sprintf('%d',
sprintf('%d', $num / $self->{interval}) * $self->{interval});
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Progress package
# ###########################################################################
# ###########################################################################
# Retry package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Retry.pm
# t/lib/Retry.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Retry;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::HiRes qw(sleep);
sub new {
my ( $class, %args ) = @_;
my $self = {
%args,
};
return bless $self, $class;
}
sub retry {
my ( $self, %args ) = @_;
my @required_args = qw(try fail final_fail);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($try, $fail, $final_fail) = @args{@required_args};
my $wait = $args{wait} || sub { sleep 1; };
my $tries = $args{tries} || 3;
my $last_error;
my $tryno = 0;
TRY:
while ( ++$tryno <= $tries ) {
PTDEBUG && _d("Try", $tryno, "of", $tries);
my $result;
eval {
$result = $try->(tryno=>$tryno);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d("Try code failed:", $EVAL_ERROR);
$last_error = $EVAL_ERROR;
if ( $tryno < $tries ) { # more retries
my $retry = $fail->(tryno=>$tryno, error=>$last_error);
last TRY unless $retry;
PTDEBUG && _d("Calling wait code");
$wait->(tryno=>$tryno);
}
}
else {
PTDEBUG && _d("Try code succeeded");
return $result;
}
}
PTDEBUG && _d('Try code did not succeed');
return $final_fail->(error=>$last_error);
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Retry package
# ###########################################################################
# ###########################################################################
# Cxn package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Cxn.pm
# t/lib/Cxn.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Cxn;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Scalar::Util qw(blessed);
use constant {
PTDEBUG => $ENV{PTDEBUG} || 0,
PERCONA_TOOLKIT_TEST_USE_DSN_NAMES => $ENV{PERCONA_TOOLKIT_TEST_USE_DSN_NAMES} || 0,
};
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(DSNParser OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
};
my ($dp, $o) = @args{@required_args};
my $dsn_defaults = $dp->parse_options($o);
my $prev_dsn = $args{prev_dsn};
my $dsn = $args{dsn};
if ( !$dsn ) {
$args{dsn_string} ||= 'h=' . ($dsn_defaults->{h} || 'localhost');
$dsn = $dp->parse(
$args{dsn_string}, $prev_dsn, $dsn_defaults);
}
elsif ( $prev_dsn ) {
$dsn = $dp->copy($prev_dsn, $dsn);
}
my $dsn_name = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
my $self = {
dsn => $dsn,
dbh => $args{dbh},
dsn_name => $dsn_name,
hostname => '',
set => $args{set},
NAME_lc => defined($args{NAME_lc}) ? $args{NAME_lc} : 1,
dbh_set => 0,
ask_pass => $o->get('ask-pass'),
DSNParser => $dp,
is_cluster_node => undef,
parent => $args{parent},
};
return bless $self, $class;
}
sub connect {
my ( $self, %opts ) = @_;
my $dsn = $opts{dsn} || $self->{dsn};
my $dp = $self->{DSNParser};
my $dbh = $self->{dbh};
if ( !$dbh || !$dbh->ping() ) {
if ( $self->{ask_pass} && !$self->{asked_for_pass} && !defined $dsn->{p} ) {
$dsn->{p} = OptionParser::prompt_noecho("Enter MySQL password: ");
$self->{asked_for_pass} = 1;
}
$dbh = $dp->get_dbh(
$dp->get_cxn_params($dsn),
{
AutoCommit => 1,
%opts,
},
);
}
$dbh = $self->set_dbh($dbh);
if ( $opts{dsn} ) {
$self->{dsn} = $dsn;
$self->{dsn_name} = $dp->as_string($dsn, [qw(h P S)])
|| $dp->as_string($dsn, [qw(F)])
|| '';
}
PTDEBUG && _d($dbh, 'Connected dbh to', $self->{hostname},$self->{dsn_name});
return $dbh;
}
sub set_dbh {
my ($self, $dbh) = @_;
if ( $self->{dbh} && $self->{dbh} == $dbh && $self->{dbh_set} ) {
PTDEBUG && _d($dbh, 'Already set dbh');
return $dbh;
}
PTDEBUG && _d($dbh, 'Setting dbh');
$dbh->{FetchHashKeyName} = 'NAME_lc' if $self->{NAME_lc};
my $sql = 'SELECT @@server_id /*!50038 , @@hostname*/';
PTDEBUG && _d($dbh, $sql);
my ($server_id, $hostname) = $dbh->selectrow_array($sql);
PTDEBUG && _d($dbh, 'hostname:', $hostname, $server_id);
if ( $hostname ) {
$self->{hostname} = $hostname;
}
if ( $self->{parent} ) {
PTDEBUG && _d($dbh, 'Setting InactiveDestroy=1 in parent');
$dbh->{InactiveDestroy} = 1;
}
if ( my $set = $self->{set}) {
$set->($dbh);
}
$self->{dbh} = $dbh;
$self->{dbh_set} = 1;
return $dbh;
}
sub lost_connection {
my ($self, $e) = @_;
return 0 unless $e;
return $e =~ m/MySQL server has gone away/
|| $e =~ m/Lost connection to MySQL server/
|| $e =~ m/Server shutdown in progress/;
}
sub dbh {
my ($self) = @_;
return $self->{dbh};
}
sub dsn {
my ($self) = @_;
return $self->{dsn};
}
sub name {
my ($self) = @_;
return $self->{dsn_name} if PERCONA_TOOLKIT_TEST_USE_DSN_NAMES;
return $self->{hostname} || $self->{dsn_name} || 'unknown host';
}
sub get_id {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $unique_id;
if ($cxn->is_cluster_node()) { # for cluster we concatenate various variables to maximize id 'uniqueness' across versions
my $sql = q{SHOW STATUS LIKE 'wsrep\_local\_index'};
my (undef, $wsrep_local_index) = $cxn->dbh->selectrow_array($sql);
PTDEBUG && _d("Got cluster wsrep_local_index: ",$wsrep_local_index);
$unique_id = $wsrep_local_index."|";
foreach my $val ('server\_id', 'wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
my $sql = "SHOW VARIABLES LIKE '$val'";
PTDEBUG && _d($cxn->name, $sql);
my (undef, $val) = $cxn->dbh->selectrow_array($sql);
$unique_id .= "|$val";
}
} else {
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
$unique_id = $cxn->dbh->selectrow_array($sql);
}
PTDEBUG && _d("Generated unique id for cluster:", $unique_id);
return $unique_id;
}
sub is_cluster_node {
my ($self, $cxn) = @_;
$cxn ||= $self;
my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
my $dbh;
if ($cxn->isa('DBI::db')) {
$dbh = $cxn;
PTDEBUG && _d($sql); #don't invoke name() if it's not a Cxn!
}
else {
$dbh = $cxn->dbh();
PTDEBUG && _d($cxn->name, $sql);
}
my $row = $dbh->selectrow_arrayref($sql);
return $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1') ? 1 : 0;
}
sub remove_duplicate_cxns {
my ($self, %args) = @_;
my @cxns = @{$args{cxns}};
my $seen_ids = $args{seen_ids} || {};
PTDEBUG && _d("Removing duplicates from ", join(" ", map { $_->name } @cxns));
my @trimmed_cxns;
for my $cxn ( @cxns ) {
my $id = $cxn->get_id();
PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
if ( ! $seen_ids->{$id}++ ) {
push @trimmed_cxns, $cxn
}
else {
PTDEBUG && _d("Removing ", $cxn->name,
", ID ", $id, ", because we've already seen it");
}
}
return \@trimmed_cxns;
}
sub DESTROY {
my ($self) = @_;
PTDEBUG && _d('Destroying cxn');
if ( $self->{parent} ) {
PTDEBUG && _d($self->{dbh}, 'Not disconnecting dbh in parent');
}
elsif ( $self->{dbh}
&& blessed($self->{dbh})
&& $self->{dbh}->can("disconnect") )
{
PTDEBUG && _d($self->{dbh}, 'Disconnecting dbh on', $self->{hostname},
$self->{dsn_name});
$self->{dbh}->disconnect();
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Cxn package
# ###########################################################################
# ###########################################################################
# MasterSlave package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MasterSlave.pm
# t/lib/MasterSlave.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MasterSlave;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub check_recursion_method {
my ($methods) = @_;
foreach my $method ( @$methods ) {
die "Invalid recursion method: " . ($method || 'undef') . "\n"
unless $method && $method =~ m/^(?:processlist$|hosts$|none$|cluster|dsn=)/i;
}
if ( @$methods > 1 ) {
if ( grep( { m/none/ } @$methods) && grep( {! m/none/ } @$methods) ) {
die "--recursion-method=none cannot be combined with other methods\n";
}
elsif ( grep({ !m/processlist|hosts/i } @$methods)
&& $methods->[0] !~ /^dsn=/i )
{
die "Invalid combination of recursion methods: "
. join(", ", map { defined($_) ? $_ : 'undef' } @$methods) . ". "
. "Only hosts and processlist may be combined.\n"
}
}
return;
}
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(OptionParser DSNParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
%args,
replication_thread => {},
};
return bless $self, $class;
}
sub get_slaves {
my ($self, %args) = @_;
my @required_args = qw(make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($make_cxn) = @args{@required_args};
my $slaves = [];
my $dp = $self->{DSNParser};
my $methods = $self->_resolve_recursion_methods($args{dsn});
return $slaves unless @$methods;
if ( grep { m/processlist|hosts/i } @$methods ) {
my @required_args = qw(dbh dsn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh, $dsn) = @args{@required_args};
$self->recurse_to_slaves(
{ dbh => $dbh,
dsn => $dsn,
callback => sub {
my ( $dsn, $dbh, $level, $parent ) = @_;
return unless $level;
PTDEBUG && _d('Found slave:', $dp->as_string($dsn));
push @$slaves, $make_cxn->(dsn => $dsn, dbh => $dbh);
return;
},
}
);
}
elsif ( $methods->[0] =~ m/^dsn=/i ) {
(my $dsn_table_dsn = join ",", @$methods) =~ s/^dsn=//i;
$slaves = $self->get_cxn_from_dsn_table(
%args,
dsn_table_dsn => $dsn_table_dsn,
);
}
elsif ( $methods->[0] =~ m/none/i ) {
PTDEBUG && _d('Not getting to slaves');
}
else {
die "Unexpected recursion methods: @$methods";
}
return $slaves;
}
sub _resolve_recursion_methods {
my ($self, $dsn) = @_;
my $o = $self->{OptionParser};
if ( $o->got('recursion-method') ) {
return $o->get('recursion-method');
}
elsif ( $dsn && ($dsn->{P} || 3306) != 3306 ) {
PTDEBUG && _d('Port number is non-standard; using only hosts method');
return [qw(hosts)];
}
else {
return $o->get('recursion-method');
}
}
sub recurse_to_slaves {
my ( $self, $args, $level ) = @_;
$level ||= 0;
my $dp = $self->{DSNParser};
my $recurse = $args->{recurse} || $self->{OptionParser}->get('recurse');
my $dsn = $args->{dsn};
my $methods = $self->_resolve_recursion_methods($dsn);
PTDEBUG && _d('Recursion methods:', @$methods);
if ( lc($methods->[0]) eq 'none' ) {
PTDEBUG && _d('Not recursing to slaves');
return;
}
my $dbh;
eval {
$dbh = $args->{dbh} || $dp->get_dbh(
$dp->get_cxn_params($dsn), { AutoCommit => 1 });
PTDEBUG && _d('Connected to', $dp->as_string($dsn));
};
if ( $EVAL_ERROR ) {
print STDERR "Cannot connect to ", $dp->as_string($dsn), "\n"
or die "Cannot print: $OS_ERROR";
return;
}
my $sql = 'SELECT @@SERVER_ID';
PTDEBUG && _d($sql);
my ($id) = $dbh->selectrow_array($sql);
PTDEBUG && _d('Working on server ID', $id);
my $master_thinks_i_am = $dsn->{server_id};
if ( !defined $id
|| ( defined $master_thinks_i_am && $master_thinks_i_am != $id )
|| $args->{server_ids_seen}->{$id}++
) {
PTDEBUG && _d('Server ID seen, or not what master said');
if ( $args->{skip_callback} ) {
$args->{skip_callback}->($dsn, $dbh, $level, $args->{parent});
}
return;
}
$args->{callback}->($dsn, $dbh, $level, $args->{parent});
if ( !defined $recurse || $level < $recurse ) {
my @slaves =
grep { !$_->{master_id} || $_->{master_id} == $id } # Only my slaves.
$self->find_slave_hosts($dp, $dbh, $dsn, $methods);
foreach my $slave ( @slaves ) {
PTDEBUG && _d('Recursing from',
$dp->as_string($dsn), 'to', $dp->as_string($slave));
$self->recurse_to_slaves(
{ %$args, dsn => $slave, dbh => undef, parent => $dsn }, $level + 1 );
}
}
}
sub find_slave_hosts {
my ( $self, $dsn_parser, $dbh, $dsn, $methods ) = @_;
PTDEBUG && _d('Looking for slaves on', $dsn_parser->as_string($dsn),
'using methods', @$methods);
my @slaves;
METHOD:
foreach my $method ( @$methods ) {
my $find_slaves = "_find_slaves_by_$method";
PTDEBUG && _d('Finding slaves with', $find_slaves);
@slaves = $self->$find_slaves($dsn_parser, $dbh, $dsn);
last METHOD if @slaves;
}
PTDEBUG && _d('Found', scalar(@slaves), 'slaves');
return @slaves;
}
sub _find_slaves_by_processlist {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves = map {
my $slave = $dsn_parser->parse("h=$_", $dsn);
$slave->{source} = 'processlist';
$slave;
}
grep { $_ }
map {
my ( $host ) = $_->{host} =~ m/^([^:]+):/;
if ( $host eq 'localhost' ) {
$host = '127.0.0.1'; # Replication never uses sockets.
}
$host;
} $self->get_connected_slaves($dbh);
return @slaves;
}
sub _find_slaves_by_hosts {
my ( $self, $dsn_parser, $dbh, $dsn ) = @_;
my @slaves;
my $sql = 'SHOW SLAVE HOSTS';
PTDEBUG && _d($dbh, $sql);
@slaves = @{$dbh->selectall_arrayref($sql, { Slice => {} })};
if ( @slaves ) {
PTDEBUG && _d('Found some SHOW SLAVE HOSTS info');
@slaves = map {
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
my $spec = "h=$hash{host},P=$hash{port}"
. ( $hash{user} ? ",u=$hash{user}" : '')
. ( $hash{password} ? ",p=$hash{password}" : '');
my $dsn = $dsn_parser->parse($spec, $dsn);
$dsn->{server_id} = $hash{server_id};
$dsn->{master_id} = $hash{master_id};
$dsn->{source} = 'hosts';
$dsn;
} @slaves;
}
return @slaves;
}
sub get_connected_slaves {
my ( $self, $dbh ) = @_;
my $show = "SHOW GRANTS FOR ";
my $user = 'CURRENT_USER()';
my $sql = $show . $user;
PTDEBUG && _d($dbh, $sql);
my $proc;
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
if ( $EVAL_ERROR ) {
if ( $EVAL_ERROR =~ m/no such grant defined for user/ ) {
PTDEBUG && _d('Retrying SHOW GRANTS without host; error:',
$EVAL_ERROR);
($user) = split('@', $user);
$sql = $show . $user;
PTDEBUG && _d($sql);
eval {
$proc = grep {
m/ALL PRIVILEGES.*?\*\.\*|PROCESS/
} @{$dbh->selectcol_arrayref($sql)};
};
}
die "Failed to $sql: $EVAL_ERROR" if $EVAL_ERROR;
}
if ( !$proc ) {
die "You do not have the PROCESS privilege";
}
$sql = 'SHOW PROCESSLIST';
PTDEBUG && _d($dbh, $sql);
grep { $_->{command} =~ m/Binlog Dump/i }
map { # Lowercase the column names
my %hash;
@hash{ map { lc $_ } keys %$_ } = values %$_;
\%hash;
}
@{$dbh->selectall_arrayref($sql, { Slice => {} })};
}
sub is_master_of {
my ( $self, $master, $slave ) = @_;
my $master_status = $self->get_master_status($master)
or die "The server specified as a master is not a master";
my $slave_status = $self->get_slave_status($slave)
or die "The server specified as a slave is not a slave";
my @connected = $self->get_connected_slaves($master)
or die "The server specified as a master has no connected slaves";
my (undef, $port) = $master->selectrow_array("SHOW VARIABLES LIKE 'port'");
if ( $port != $slave_status->{master_port} ) {
die "The slave is connected to $slave_status->{master_port} "
. "but the master's port is $port";
}
if ( !grep { $slave_status->{master_user} eq $_->{user} } @connected ) {
die "I don't see any slave I/O thread connected with user "
. $slave_status->{master_user};
}
if ( ($slave_status->{slave_io_state} || '')
eq 'Waiting for master to send event' )
{
my ( $master_log_name, $master_log_num )
= $master_status->{file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
my ( $slave_log_name, $slave_log_num )
= $slave_status->{master_log_file} =~ m/^(.*?)\.0*([1-9][0-9]*)$/;
if ( $master_log_name ne $slave_log_name
|| abs($master_log_num - $slave_log_num) > 1 )
{
die "The slave thinks it is reading from "
. "$slave_status->{master_log_file}, but the "
. "master is writing to $master_status->{file}";
}
}
return 1;
}
sub get_master_dsn {
my ( $self, $dbh, $dsn, $dsn_parser ) = @_;
my $master = $self->get_slave_status($dbh) or return undef;
my $spec = "h=$master->{master_host},P=$master->{master_port}";
return $dsn_parser->parse($spec, $dsn);
}
sub get_slave_status {
my ( $self, $dbh ) = @_;
if ( !$self->{not_a_slave}->{$dbh} ) {
my $sth = $self->{sths}->{$dbh}->{SLAVE_STATUS}
||= $dbh->prepare('SHOW SLAVE STATUS');
PTDEBUG && _d($dbh, 'SHOW SLAVE STATUS');
$sth->execute();
my ($ss) = @{$sth->fetchall_arrayref({})};
if ( $ss && %$ss ) {
$ss = { map { lc($_) => $ss->{$_} } keys %$ss }; # lowercase the keys
return $ss;
}
PTDEBUG && _d('This server returns nothing for SHOW SLAVE STATUS');
$self->{not_a_slave}->{$dbh}++;
}
}
sub get_master_status {
my ( $self, $dbh ) = @_;
if ( $self->{not_a_master}->{$dbh} ) {
PTDEBUG && _d('Server on dbh', $dbh, 'is not a master');
return;
}
my $sth = $self->{sths}->{$dbh}->{MASTER_STATUS}
||= $dbh->prepare('SHOW MASTER STATUS');
PTDEBUG && _d($dbh, 'SHOW MASTER STATUS');
$sth->execute();
my ($ms) = @{$sth->fetchall_arrayref({})};
PTDEBUG && _d(
$ms ? map { "$_=" . (defined $ms->{$_} ? $ms->{$_} : '') } keys %$ms
: '');
if ( !$ms || scalar keys %$ms < 2 ) {
PTDEBUG && _d('Server on dbh', $dbh, 'does not seem to be a master');
$self->{not_a_master}->{$dbh}++;
}
return { map { lc($_) => $ms->{$_} } keys %$ms }; # lowercase the keys
}
sub wait_for_master {
my ( $self, %args ) = @_;
my @required_args = qw(master_status slave_dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($master_status, $slave_dbh) = @args{@required_args};
my $timeout = $args{timeout} || 60;
my $result;
my $waited;
if ( $master_status ) {
my $sql = "SELECT MASTER_POS_WAIT('$master_status->{file}', "
. "$master_status->{position}, $timeout)";
PTDEBUG && _d($slave_dbh, $sql);
my $start = time;
($result) = $slave_dbh->selectrow_array($sql);
$waited = time - $start;
PTDEBUG && _d('Result of waiting:', $result);
PTDEBUG && _d("Waited", $waited, "seconds");
}
else {
PTDEBUG && _d('Not waiting: this server is not a master');
}
return {
result => $result,
waited => $waited,
};
}
sub stop_slave {
my ( $self, $dbh ) = @_;
my $sth = $self->{sths}->{$dbh}->{STOP_SLAVE}
||= $dbh->prepare('STOP SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
sub start_slave {
my ( $self, $dbh, $pos ) = @_;
if ( $pos ) {
my $sql = "START SLAVE UNTIL MASTER_LOG_FILE='$pos->{file}', "
. "MASTER_LOG_POS=$pos->{position}";
PTDEBUG && _d($dbh, $sql);
$dbh->do($sql);
}
else {
my $sth = $self->{sths}->{$dbh}->{START_SLAVE}
||= $dbh->prepare('START SLAVE');
PTDEBUG && _d($dbh, $sth->{Statement});
$sth->execute();
}
}
sub catchup_to_master {
my ( $self, $slave, $master, $timeout ) = @_;
$self->stop_slave($master);
$self->stop_slave($slave);
my $slave_status = $self->get_slave_status($slave);
my $slave_pos = $self->repl_posn($slave_status);
my $master_status = $self->get_master_status($master);
my $master_pos = $self->repl_posn($master_status);
PTDEBUG && _d('Master position:', $self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
my $result;
if ( $self->pos_cmp($slave_pos, $master_pos) < 0 ) {
PTDEBUG && _d('Waiting for slave to catch up to master');
$self->start_slave($slave, $master_pos);
$result = $self->wait_for_master(
master_status => $master_status,
slave_dbh => $slave,
timeout => $timeout,
master_status => $master_status
);
if ( !defined $result->{result} ) {
$slave_status = $self->get_slave_status($slave);
if ( !$self->slave_is_running($slave_status) ) {
PTDEBUG && _d('Master position:',
$self->pos_to_string($master_pos),
'Slave position:', $self->pos_to_string($slave_pos));
$slave_pos = $self->repl_posn($slave_status);
if ( $self->pos_cmp($slave_pos, $master_pos) != 0 ) {
die "MASTER_POS_WAIT() returned NULL but slave has not "
. "caught up to master";
}
PTDEBUG && _d('Slave is caught up to master and stopped');
}
else {
die "Slave has not caught up to master and it is still running";
}
}
}
else {
PTDEBUG && _d("Slave is already caught up to master");
}
return $result;
}
sub catchup_to_same_pos {
my ( $self, $s1_dbh, $s2_dbh ) = @_;
$self->stop_slave($s1_dbh);
$self->stop_slave($s2_dbh);
my $s1_status = $self->get_slave_status($s1_dbh);
my $s2_status = $self->get_slave_status($s2_dbh);
my $s1_pos = $self->repl_posn($s1_status);
my $s2_pos = $self->repl_posn($s2_status);
if ( $self->pos_cmp($s1_pos, $s2_pos) < 0 ) {
$self->start_slave($s1_dbh, $s2_pos);
}
elsif ( $self->pos_cmp($s2_pos, $s1_pos) < 0 ) {
$self->start_slave($s2_dbh, $s1_pos);
}
$s1_status = $self->get_slave_status($s1_dbh);
$s2_status = $self->get_slave_status($s2_dbh);
$s1_pos = $self->repl_posn($s1_status);
$s2_pos = $self->repl_posn($s2_status);
if ( $self->slave_is_running($s1_status)
|| $self->slave_is_running($s2_status)
|| $self->pos_cmp($s1_pos, $s2_pos) != 0)
{
die "The servers aren't both stopped at the same position";
}
}
sub slave_is_running {
my ( $self, $slave_status ) = @_;
return ($slave_status->{slave_sql_running} || 'No') eq 'Yes';
}
sub has_slave_updates {
my ( $self, $dbh ) = @_;
my $sql = q{SHOW VARIABLES LIKE 'log_slave_updates'};
PTDEBUG && _d($dbh, $sql);
my ($name, $value) = $dbh->selectrow_array($sql);
return $value && $value =~ m/^(1|ON)$/;
}
sub repl_posn {
my ( $self, $status ) = @_;
if ( exists $status->{file} && exists $status->{position} ) {
return {
file => $status->{file},
position => $status->{position},
};
}
else {
return {
file => $status->{relay_master_log_file},
position => $status->{exec_master_log_pos},
};
}
}
sub get_slave_lag {
my ( $self, $dbh ) = @_;
my $stat = $self->get_slave_status($dbh);
return unless $stat; # server is not a slave
return $stat->{seconds_behind_master};
}
sub pos_cmp {
my ( $self, $a, $b ) = @_;
return $self->pos_to_string($a) cmp $self->pos_to_string($b);
}
sub short_host {
my ( $self, $dsn ) = @_;
my ($host, $port);
if ( $dsn->{master_host} ) {
$host = $dsn->{master_host};
$port = $dsn->{master_port};
}
else {
$host = $dsn->{h};
$port = $dsn->{P};
}
return ($host || '[default]') . ( ($port || 3306) == 3306 ? '' : ":$port" );
}
sub is_replication_thread {
my ( $self, $query, %args ) = @_;
return unless $query;
my $type = lc($args{type} || 'all');
die "Invalid type: $type"
unless $type =~ m/^binlog_dump|slave_io|slave_sql|all$/i;
my $match = 0;
if ( $type =~ m/binlog_dump|all/i ) {
$match = 1
if ($query->{Command} || $query->{command} || '') eq "Binlog Dump";
}
if ( !$match ) {
if ( ($query->{User} || $query->{user} || '') eq "system user" ) {
PTDEBUG && _d("Slave replication thread");
if ( $type ne 'all' ) {
my $state = $query->{State} || $query->{state} || '';
if ( $state =~ m/^init|end$/ ) {
PTDEBUG && _d("Special state:", $state);
$match = 1;
}
else {
my ($slave_sql) = $state =~ m/
^(Waiting\sfor\sthe\snext\sevent
|Reading\sevent\sfrom\sthe\srelay\slog
|Has\sread\sall\srelay\slog;\swaiting
|Making\stemp\sfile
|Waiting\sfor\sslave\smutex\son\sexit)/xi;
$match = $type eq 'slave_sql' && $slave_sql ? 1
: $type eq 'slave_io' && !$slave_sql ? 1
: 0;
}
}
else {
$match = 1;
}
}
else {
PTDEBUG && _d('Not system user');
}
if ( !defined $args{check_known_ids} || $args{check_known_ids} ) {
my $id = $query->{Id} || $query->{id};
if ( $match ) {
$self->{replication_thread}->{$id} = 1;
}
else {
if ( $self->{replication_thread}->{$id} ) {
PTDEBUG && _d("Thread ID is a known replication thread ID");
$match = 1;
}
}
}
}
PTDEBUG && _d('Matches', $type, 'replication thread:',
($match ? 'yes' : 'no'), '; match:', $match);
return $match;
}
sub get_replication_filters {
my ( $self, %args ) = @_;
my @required_args = qw(dbh);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dbh) = @args{@required_args};
my %filters = ();
my $status = $self->get_master_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
binlog_do_db
binlog_ignore_db
);
}
$status = $self->get_slave_status($dbh);
if ( $status ) {
map { $filters{$_} = $status->{$_} }
grep { defined $status->{$_} && $status->{$_} ne '' }
qw(
replicate_do_db
replicate_ignore_db
replicate_do_table
replicate_ignore_table
replicate_wild_do_table
replicate_wild_ignore_table
);
my $sql = "SHOW VARIABLES LIKE 'slave_skip_errors'";
PTDEBUG && _d($dbh, $sql);
my $row = $dbh->selectrow_arrayref($sql);
$filters{slave_skip_errors} = $row->[1] if $row->[1] && $row->[1] ne 'OFF';
}
return \%filters;
}
sub pos_to_string {
my ( $self, $pos ) = @_;
my $fmt = '%s/%020d';
return sprintf($fmt, @{$pos}{qw(file position)});
}
sub reset_known_replication_threads {
my ( $self ) = @_;
$self->{replication_thread} = {};
return;
}
sub get_cxn_from_dsn_table {
my ($self, %args) = @_;
my @required_args = qw(dsn_table_dsn make_cxn);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($dsn_table_dsn, $make_cxn) = @args{@required_args};
PTDEBUG && _d('DSN table DSN:', $dsn_table_dsn);
my $dp = $self->{DSNParser};
my $q = $self->{Quoter};
my $dsn = $dp->parse($dsn_table_dsn);
my $dsn_table;
if ( $dsn->{D} && $dsn->{t} ) {
$dsn_table = $q->quote($dsn->{D}, $dsn->{t});
}
elsif ( $dsn->{t} && $dsn->{t} =~ m/\./ ) {
$dsn_table = $q->quote($q->split_unquote($dsn->{t}));
}
else {
die "DSN table DSN does not specify a database (D) "
. "or a database-qualified table (t)";
}
my $dsn_tbl_cxn = $make_cxn->(dsn => $dsn);
my $dbh = $dsn_tbl_cxn->connect();
my $sql = "SELECT dsn FROM $dsn_table ORDER BY id";
PTDEBUG && _d($sql);
my $dsn_strings = $dbh->selectcol_arrayref($sql);
my @cxn;
if ( $dsn_strings ) {
foreach my $dsn_string ( @$dsn_strings ) {
PTDEBUG && _d('DSN from DSN table:', $dsn_string);
push @cxn, $make_cxn->(dsn_string => $dsn_string);
}
}
return \@cxn;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MasterSlave package
# ###########################################################################
# ###########################################################################
# ReplicaLagWaiter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/ReplicaLagWaiter.pm
# t/lib/ReplicaLagWaiter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package ReplicaLagWaiter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::HiRes qw(sleep time);
use Data::Dumper;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(oktorun get_lag sleep max_lag slaves);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $self = {
%args,
};
return bless $self, $class;
}
sub wait {
my ( $self, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $pr = $args{Progress};
my $oktorun = $self->{oktorun};
my $get_lag = $self->{get_lag};
my $sleep = $self->{sleep};
my $slaves = $self->{slaves};
my $max_lag = $self->{max_lag};
my $worst; # most lagging slave
my $pr_callback;
my $pr_first_report;
if ( $pr ) {
$pr_callback = sub {
my ($fraction, $elapsed, $remaining, $eta, $completed) = @_;
my $dsn_name = $worst->{cxn}->name();
if ( defined $worst->{lag} ) {
print STDERR "Replica lag is " . ($worst->{lag} || '?')
. " seconds on $dsn_name. Waiting.\n";
}
else {
print STDERR "Replica $dsn_name is stopped. Waiting.\n";
}
return;
};
$pr->set_callback($pr_callback);
$pr_first_report = sub {
my $dsn_name = $worst->{cxn}->name();
if ( !defined $worst->{lag} ) {
print STDERR "Replica $dsn_name is stopped. Waiting.\n";
}
return;
};
}
my @lagged_slaves = map { {cxn=>$_, lag=>undef} } @$slaves;
while ( $oktorun->() && @lagged_slaves ) {
PTDEBUG && _d('Checking slave lag');
for my $i ( 0..$#lagged_slaves ) {
my $lag = $get_lag->($lagged_slaves[$i]->{cxn});
PTDEBUG && _d($lagged_slaves[$i]->{cxn}->name(),
'slave lag:', $lag);
if ( !defined $lag || $lag > $max_lag ) {
$lagged_slaves[$i]->{lag} = $lag;
}
else {
delete $lagged_slaves[$i];
}
}
@lagged_slaves = grep { defined $_ } @lagged_slaves;
if ( @lagged_slaves ) {
@lagged_slaves = reverse sort {
defined $a->{lag} && defined $b->{lag} ? $a->{lag} <=> $b->{lag}
: defined $a->{lag} ? -1
: 1;
} @lagged_slaves;
$worst = $lagged_slaves[0];
PTDEBUG && _d(scalar @lagged_slaves, 'slaves are lagging, worst:',
$worst->{lag}, 'on', Dumper($worst->{cxn}->dsn()));
if ( $pr ) {
$pr->update(
sub { return 0; },
first_report => $pr_first_report,
);
}
PTDEBUG && _d('Calling sleep callback');
$sleep->($worst->{cxn}, $worst->{lag});
}
}
PTDEBUG && _d('All slaves caught up');
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End ReplicaLagWaiter package
# ###########################################################################
# ###########################################################################
# FlowControlWaiter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/FlowControlWaiter.pm
# t/lib/FlowControlWaiter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package FlowControlWaiter;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::HiRes qw(sleep time);
use Data::Dumper;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(oktorun node sleep max_flow_ctl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $self = {
%args
};
$self->{last_time} = time();
my (undef, $last_fc_ns) = $self->{node}->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"');
$self->{last_fc_secs} = $last_fc_ns/1000_000_000;
return bless $self, $class;
}
sub wait {
my ( $self, %args ) = @_;
my @required_args = qw();
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $pr = $args{Progress};
my $oktorun = $self->{oktorun};
my $sleep = $self->{sleep};
my $node = $self->{node};
my $max_avg = $self->{max_flow_ctl}/100;
my $too_much_fc = 1;
my $pr_callback;
if ( $pr ) {
$pr_callback = sub {
print STDERR "Pausing because PXC Flow Control is active\n";
return;
};
$pr->set_callback($pr_callback);
}
while ( $oktorun->() && $too_much_fc ) {
my $current_time = time();
my (undef, $current_fc_ns) = $node->selectrow_array('SHOW STATUS LIKE "wsrep_flow_control_paused_ns"');
my $current_fc_secs = $current_fc_ns/1000_000_000;
my $current_avg = ($current_fc_secs - $self->{last_fc_secs}) / ($current_time - $self->{last_time});
if ( $current_avg > $max_avg ) {
if ( $pr ) {
$pr->update(sub { return 0; });
}
PTDEBUG && _d('Calling sleep callback');
if ( $self->{simple_progress} ) {
print STDERR "Waiting for Flow Control to abate\n";
}
$sleep->();
} else {
$too_much_fc = 0;
}
$self->{last_time} = $current_time;
$self->{last_fc_secs} = $current_fc_secs;
}
PTDEBUG && _d('Flow Control is Ok');
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End FlowControlWaiter package
# ###########################################################################
# ###########################################################################
# MySQLStatusWaiter package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/MySQLStatusWaiter.pm
# t/lib/MySQLStatusWaiter.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package MySQLStatusWaiter;
use strict;
use warnings FATAL => 'all';
use POSIX qw( ceil );
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(max_spec get_status sleep oktorun);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
PTDEBUG && _d('Parsing spec for max thresholds');
my $max_val_for = _parse_spec($args{max_spec});
if ( $max_val_for ) {
_check_and_set_vals(
vars => $max_val_for,
get_status => $args{get_status},
threshold_factor => 0.2, # +20%
);
}
PTDEBUG && _d('Parsing spec for critical thresholds');
my $critical_val_for = _parse_spec($args{critical_spec} || []);
if ( $critical_val_for ) {
_check_and_set_vals(
vars => $critical_val_for,
get_status => $args{get_status},
threshold_factor => 1.0, # double (x2; +100%)
);
}
my $self = {
get_status => $args{get_status},
sleep => $args{sleep},
oktorun => $args{oktorun},
max_val_for => $max_val_for,
critical_val_for => $critical_val_for,
};
return bless $self, $class;
}
sub _parse_spec {
my ($spec) = @_;
return unless $spec && scalar @$spec;
my %max_val_for;
foreach my $var_val ( @$spec ) {
die "Empty or undefined spec\n" unless $var_val;
$var_val =~ s/^\s+//;
$var_val =~ s/\s+$//g;
my ($var, $val) = split /[:=]/, $var_val;
die "$var_val does not contain a variable\n" unless $var;
die "$var is not a variable name\n" unless $var =~ m/^[a-zA-Z_]+$/;
if ( !$val ) {
PTDEBUG && _d('Will get intial value for', $var, 'later');
$max_val_for{$var} = undef;
}
else {
die "The value for $var must be a number\n"
unless $val =~ m/^[\d\.]+$/;
$max_val_for{$var} = $val;
}
}
return \%max_val_for;
}
sub max_values {
my ($self) = @_;
return $self->{max_val_for};
}
sub critical_values {
my ($self) = @_;
return $self->{critical_val_for};
}
sub wait {
my ( $self, %args ) = @_;
return unless $self->{max_val_for};
my $pr = $args{Progress}; # optional
my $oktorun = $self->{oktorun};
my $get_status = $self->{get_status};
my $sleep = $self->{sleep};
my %vals_too_high = %{$self->{max_val_for}};
my $pr_callback;
if ( $pr ) {
$pr_callback = sub {
print STDERR "Pausing because "
. join(', ',
map {
"$_="
. (defined $vals_too_high{$_} ? $vals_too_high{$_}
: 'unknown')
} sort keys %vals_too_high
)
. ".\n";
return;
};
$pr->set_callback($pr_callback);
}
while ( $oktorun->() ) {
PTDEBUG && _d('Checking status variables');
foreach my $var ( sort keys %vals_too_high ) {
my $val = $get_status->($var);
PTDEBUG && _d($var, '=', $val);
if ( $val
&& exists $self->{critical_val_for}->{$var}
&& $val >= $self->{critical_val_for}->{$var} ) {
die "$var=$val exceeds its critical threshold "
. "$self->{critical_val_for}->{$var}\n";
}
if ( !$val || $val >= $self->{max_val_for}->{$var} ) {
$vals_too_high{$var} = $val;
}
else {
delete $vals_too_high{$var};
}
}
last unless scalar keys %vals_too_high;
PTDEBUG && _d(scalar keys %vals_too_high, 'values are too high:',
%vals_too_high);
if ( $pr ) {
$pr->update(sub { return 0; });
}
PTDEBUG && _d('Calling sleep callback');
$sleep->();
%vals_too_high = %{$self->{max_val_for}}; # recheck all vars
}
PTDEBUG && _d('All var vals are low enough');
return;
}
sub _check_and_set_vals {
my (%args) = @_;
my @required_args = qw(vars get_status threshold_factor);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($vars, $get_status, $threshold_factor) = @args{@required_args};
PTDEBUG && _d('Checking and setting values');
return unless $vars && scalar %$vars;
foreach my $var ( keys %$vars ) {
my $init_val = $get_status->($var);
die "Variable $var does not exist or its value is undefined\n"
unless defined $init_val;
my $val;
if ( defined $vars->{$var} ) {
$val = $vars->{$var};
}
else {
PTDEBUG && _d('Initial', $var, 'value:', $init_val);
$val = ($init_val * $threshold_factor) + $init_val;
$vars->{$var} = int(ceil($val));
}
PTDEBUG && _d('Wait if', $var, '>=', $val);
}
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End MySQLStatusWaiter package
# ###########################################################################
# ###########################################################################
# WeightedAvgRate package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/WeightedAvgRate.pm
# t/lib/WeightedAvgRate.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package WeightedAvgRate;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(target_t);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my $self = {
%args,
avg_n => 0,
avg_t => 0,
weight => $args{weight} || 0.75,
};
return bless $self, $class;
}
sub update {
my ($self, $n, $t) = @_;
PTDEBUG && _d('Master op time:', $n, 'n /', $t, 's');
if ( $self->{avg_n} && $self->{avg_t} ) {
$self->{avg_n} = ($self->{avg_n} * $self->{weight}) + $n;
$self->{avg_t} = ($self->{avg_t} * $self->{weight}) + $t;
$self->{avg_rate} = $self->{avg_n} / $self->{avg_t};
PTDEBUG && _d('Weighted avg rate:', $self->{avg_rate}, 'n/s');
}
else {
$self->{avg_n} = $n;
$self->{avg_t} = $t;
$self->{avg_rate} = $self->{avg_n} / $self->{avg_t};
PTDEBUG && _d('Initial avg rate:', $self->{avg_rate}, 'n/s');
}
my $new_n = int($self->{avg_rate} * $self->{target_t});
PTDEBUG && _d('Adjust n to', $new_n);
return $new_n;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End WeightedAvgRate package
# ###########################################################################
# ###########################################################################
# NibbleIterator package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/NibbleIterator.pm
# t/lib/NibbleIterator.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package NibbleIterator;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(Cxn tbl chunk_size OptionParser Quoter TableNibbler TableParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn, $tbl, $chunk_size, $o, $q) = @args{@required_args};
my $nibble_params = can_nibble(%args);
my %comments = (
bite => "bite table",
nibble => "nibble table",
);
if ( $args{comments} ) {
map { $comments{$_} = $args{comments}->{$_} }
grep { defined $args{comments}->{$_} }
keys %{$args{comments}};
}
my $where = $o->has('where') ? $o->get('where') : '';
my $tbl_struct = $tbl->{tbl_struct};
my $ignore_col = $o->has('ignore-columns')
? ($o->get('ignore-columns') || {})
: {};
my $all_cols = $o->has('columns')
? ($o->get('columns') || $tbl_struct->{cols})
: $tbl_struct->{cols};
my @cols = grep { !$ignore_col->{$_} } @$all_cols;
my $self;
if ( $nibble_params->{one_nibble} ) {
my $nibble_sql
= ($args{dml} ? "$args{dml} " : "SELECT ")
. ($args{select} ? $args{select}
: join(', ', map { $q->quote($_) } @cols))
. " FROM $tbl->{name}"
. ($where ? " WHERE $where" : '')
. ($args{lock_in_share_mode} ? " LOCK IN SHARE MODE" : "")
. " /*$comments{bite}*/";
PTDEBUG && _d('One nibble statement:', $nibble_sql);
my $explain_nibble_sql
= "EXPLAIN SELECT "
. ($args{select} ? $args{select}
: join(', ', map { $q->quote($_) } @cols))
. " FROM $tbl->{name}"
. ($where ? " WHERE $where" : '')
. ($args{lock_in_share_mode} ? " LOCK IN SHARE MODE" : "")
. " /*explain $comments{bite}*/";
PTDEBUG && _d('Explain one nibble statement:', $explain_nibble_sql);
$self = {
%args,
one_nibble => 1,
limit => 0,
nibble_sql => $nibble_sql,
explain_nibble_sql => $explain_nibble_sql,
};
}
else {
my $index = $nibble_params->{index}; # brevity
my $index_cols = $tbl->{tbl_struct}->{keys}->{$index}->{cols};
my $asc = $args{TableNibbler}->generate_asc_stmt(
%args,
tbl_struct => $tbl->{tbl_struct},
index => $index,
n_index_cols => $args{n_chunk_index_cols},
cols => \@cols,
asc_only => 1,
);
PTDEBUG && _d('Ascend params:', Dumper($asc));
my $from = "$tbl->{name} FORCE INDEX(`$index`)";
my $order_by = join(', ', map {$q->quote($_)} @{$index_cols});
my $first_lb_sql
= "SELECT /*!40001 SQL_NO_CACHE */ "
. join(', ', map { $q->quote($_) } @{$asc->{scols}})
. " FROM $from"
. ($where ? " WHERE $where" : '')
. " ORDER BY $order_by"
. " LIMIT 1"
. " /*first lower boundary*/";
PTDEBUG && _d('First lower boundary statement:', $first_lb_sql);
my $resume_lb_sql;
if ( $args{resume} ) {
$resume_lb_sql
= "SELECT /*!40001 SQL_NO_CACHE */ "
. join(', ', map { $q->quote($_) } @{$asc->{scols}})
. " FROM $from"
. " WHERE " . $asc->{boundaries}->{'>'}
. ($where ? " AND ($where)" : '')
. " ORDER BY $order_by"
. " LIMIT 1"
. " /*resume lower boundary*/";
PTDEBUG && _d('Resume lower boundary statement:', $resume_lb_sql);
}
my $last_ub_sql
= "SELECT /*!40001 SQL_NO_CACHE */ "
. join(', ', map { $q->quote($_) } @{$asc->{scols}})
. " FROM $from"
. ($where ? " WHERE $where" : '')
. " ORDER BY "
. join(' DESC, ', map {$q->quote($_)} @{$index_cols}) . ' DESC'
. " LIMIT 1"
. " /*last upper boundary*/";
PTDEBUG && _d('Last upper boundary statement:', $last_ub_sql);
my $ub_sql
= "SELECT /*!40001 SQL_NO_CACHE */ "
. join(', ', map { $q->quote($_) } @{$asc->{scols}})
. " FROM $from"
. " WHERE " . $asc->{boundaries}->{'>='}
. ($where ? " AND ($where)" : '')
. " ORDER BY $order_by"
. " LIMIT ?, 2"
. " /*next chunk boundary*/";
PTDEBUG && _d('Upper boundary statement:', $ub_sql);
my $nibble_sql
= ($args{dml} ? "$args{dml} " : "SELECT ")
. ($args{select} ? $args{select}
: join(', ', map { $q->quote($_) } @{$asc->{cols}}))
. " FROM $from"
. " WHERE " . $asc->{boundaries}->{'>='} # lower boundary
. " AND " . $asc->{boundaries}->{'<='} # upper boundary
. ($where ? " AND ($where)" : '')
. ($args{order_by} ? " ORDER BY $order_by" : "")
. ($args{lock_in_share_mode} ? " LOCK IN SHARE MODE" : "")
. " /*$comments{nibble}*/";
PTDEBUG && _d('Nibble statement:', $nibble_sql);
my $explain_nibble_sql
= "EXPLAIN SELECT "
. ($args{select} ? $args{select}
: join(', ', map { $q->quote($_) } @{$asc->{cols}}))
. " FROM $from"
. " WHERE " . $asc->{boundaries}->{'>='} # lower boundary
. " AND " . $asc->{boundaries}->{'<='} # upper boundary
. ($where ? " AND ($where)" : '')
. ($args{order_by} ? " ORDER BY $order_by" : "")
. ($args{lock_in_share_mode} ? " LOCK IN SHARE MODE" : "")
. " /*explain $comments{nibble}*/";
PTDEBUG && _d('Explain nibble statement:', $explain_nibble_sql);
my $limit = $chunk_size - 1;
PTDEBUG && _d('Initial chunk size (LIMIT):', $limit);
$self = {
%args,
index => $index,
limit => $limit,
first_lb_sql => $first_lb_sql,
last_ub_sql => $last_ub_sql,
ub_sql => $ub_sql,
nibble_sql => $nibble_sql,
explain_first_lb_sql => "EXPLAIN $first_lb_sql",
explain_ub_sql => "EXPLAIN $ub_sql",
explain_nibble_sql => $explain_nibble_sql,
resume_lb_sql => $resume_lb_sql,
sql => {
columns => $asc->{scols},
from => $from,
where => $where,
boundaries => $asc->{boundaries},
order_by => $order_by,
},
};
}
$self->{row_est} = $nibble_params->{row_est},
$self->{nibbleno} = 0;
$self->{have_rows} = 0;
$self->{rowno} = 0;
$self->{oktonibble} = 1;
return bless $self, $class;
}
sub next {
my ($self) = @_;
if ( !$self->{oktonibble} ) {
PTDEBUG && _d('Not ok to nibble');
return;
}
my %callback_args = (
Cxn => $self->{Cxn},
tbl => $self->{tbl},
NibbleIterator => $self,
);
if ($self->{nibbleno} == 0) {
$self->_prepare_sths();
$self->_get_bounds();
if ( my $callback = $self->{callbacks}->{init} ) {
$self->{oktonibble} = $callback->(%callback_args);
PTDEBUG && _d('init callback returned', $self->{oktonibble});
if ( !$self->{oktonibble} ) {
$self->{no_more_boundaries} = 1;
return;
}
}
if ( !$self->{one_nibble} && !$self->{first_lower} ) {
PTDEBUG && _d('No first lower boundary, table must be empty');
$self->{no_more_boundaries} = 1;
return;
}
}
NIBBLE:
while ( $self->{have_rows} || $self->_next_boundaries() ) {
if ( !$self->{have_rows} ) {
$self->{nibbleno}++;
PTDEBUG && _d('Nibble:', $self->{nibble_sth}->{Statement}, 'params:',
join(', ', (@{$self->{lower} || []}, @{$self->{upper} || []})));
if ( my $callback = $self->{callbacks}->{exec_nibble} ) {
$self->{have_rows} = $callback->(%callback_args);
}
else {
$self->{nibble_sth}->execute(@{$self->{lower}}, @{$self->{upper}});
$self->{have_rows} = $self->{nibble_sth}->rows();
}
PTDEBUG && _d($self->{have_rows}, 'rows in nibble', $self->{nibbleno});
}
if ( $self->{have_rows} ) {
my $row = $self->{nibble_sth}->fetchrow_arrayref();
if ( $row ) {
$self->{rowno}++;
PTDEBUG && _d('Row', $self->{rowno}, 'in nibble',$self->{nibbleno});
return [ @$row ];
}
}
PTDEBUG && _d('No rows in nibble or nibble skipped');
if ( my $callback = $self->{callbacks}->{after_nibble} ) {
$callback->(%callback_args);
}
$self->{rowno} = 0;
$self->{have_rows} = 0;
}
PTDEBUG && _d('Done nibbling');
if ( my $callback = $self->{callbacks}->{done} ) {
$callback->(%callback_args);
}
return;
}
sub nibble_number {
my ($self) = @_;
return $self->{nibbleno};
}
sub set_nibble_number {
my ($self, $n) = @_;
die "I need a number" unless $n;
$self->{nibbleno} = $n;
PTDEBUG && _d('Set new nibble number:', $n);
return;
}
sub nibble_index {
my ($self) = @_;
return $self->{index};
}
sub statements {
my ($self) = @_;
return {
explain_first_lower_boundary => $self->{explain_first_lb_sth},
nibble => $self->{nibble_sth},
explain_nibble => $self->{explain_nibble_sth},
upper_boundary => $self->{ub_sth},
explain_upper_boundary => $self->{explain_ub_sth},
}
}
sub boundaries {
my ($self) = @_;
return {
first_lower => $self->{first_lower},
lower => $self->{lower},
upper => $self->{upper},
next_lower => $self->{next_lower},
last_upper => $self->{last_upper},
};
}
sub set_boundary {
my ($self, $boundary, $values) = @_;
die "I need a boundary parameter"
unless $boundary;
die "Invalid boundary: $boundary"
unless $boundary =~ m/^(?:lower|upper|next_lower|last_upper)$/;
die "I need a values arrayref parameter"
unless $values && ref $values eq 'ARRAY';
$self->{$boundary} = $values;
PTDEBUG && _d('Set new', $boundary, 'boundary:', Dumper($values));
return;
}
sub one_nibble {
my ($self) = @_;
return $self->{one_nibble};
}
sub limit {
my ($self) = @_;
return $self->{limit};
}
sub set_chunk_size {
my ($self, $limit) = @_;
return if $self->{one_nibble};
die "Chunk size must be > 0" unless $limit;
$self->{limit} = $limit - 1;
PTDEBUG && _d('Set new chunk size (LIMIT):', $limit);
return;
}
sub sql {
my ($self) = @_;
return $self->{sql};
}
sub more_boundaries {
my ($self) = @_;
return !$self->{no_more_boundaries};
}
sub row_estimate {
my ($self) = @_;
return $self->{row_est};
}
sub can_nibble {
my (%args) = @_;
my @required_args = qw(Cxn tbl chunk_size OptionParser TableParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn, $tbl, $chunk_size, $o) = @args{@required_args};
my $where = $o->has('where') ? $o->get('where') : '';
my ($row_est, $mysql_index) = get_row_estimate(
Cxn => $cxn,
tbl => $tbl,
where => $where,
);
if ( !$where ) {
$mysql_index = undef;
}
my $chunk_size_limit = $o->get('chunk-size-limit') || 1;
my $one_nibble = !defined $args{one_nibble} || $args{one_nibble}
? $row_est <= $chunk_size * $chunk_size_limit
: 0;
PTDEBUG && _d('One nibble:', $one_nibble ? 'yes' : 'no');
if ( $args{resume}
&& !defined $args{resume}->{lower_boundary}
&& !defined $args{resume}->{upper_boundary} ) {
PTDEBUG && _d('Resuming from one nibble table');
$one_nibble = 1;
}
my $index = _find_best_index(%args, mysql_index => $mysql_index);
if ( !$index && !$one_nibble ) {
die "There is no good index and the table is oversized.";
}
return {
row_est => $row_est, # nibble about this many rows
index => $index, # using this index
one_nibble => $one_nibble, # if the table fits in one nibble/chunk
};
}
sub _find_best_index {
my (%args) = @_;
my @required_args = qw(Cxn tbl TableParser);
my ($cxn, $tbl, $tp) = @args{@required_args};
my $tbl_struct = $tbl->{tbl_struct};
my $indexes = $tbl_struct->{keys};
my $want_index = $args{chunk_index};
if ( $want_index ) {
PTDEBUG && _d('User wants to use index', $want_index);
if ( !exists $indexes->{$want_index} ) {
PTDEBUG && _d('Cannot use user index because it does not exist');
$want_index = undef;
}
}
if ( !$want_index && $args{mysql_index} ) {
PTDEBUG && _d('MySQL wants to use index', $args{mysql_index});
$want_index = $args{mysql_index};
}
my $best_index;
my @possible_indexes;
if ( $want_index ) {
if ( $indexes->{$want_index}->{is_unique} ) {
PTDEBUG && _d('Will use wanted index');
$best_index = $want_index;
}
else {
PTDEBUG && _d('Wanted index is a possible index');
push @possible_indexes, $want_index;
}
}
else {
PTDEBUG && _d('Auto-selecting best index');
foreach my $index ( $tp->sort_indexes($tbl_struct) ) {
if ( $index eq 'PRIMARY' || $indexes->{$index}->{is_unique} ) {
$best_index = $index;
last;
}
else {
push @possible_indexes, $index;
}
}
}
if ( !$best_index && @possible_indexes ) {
PTDEBUG && _d('No PRIMARY or unique indexes;',
'will use index with highest cardinality');
foreach my $index ( @possible_indexes ) {
$indexes->{$index}->{cardinality} = _get_index_cardinality(
%args,
index => $index,
);
}
@possible_indexes = sort {
my $cmp
= $indexes->{$b}->{cardinality} <=> $indexes->{$a}->{cardinality};
if ( $cmp == 0 ) {
$cmp = scalar @{$indexes->{$b}->{cols}}
<=> scalar @{$indexes->{$a}->{cols}};
}
$cmp;
} @possible_indexes;
$best_index = $possible_indexes[0];
}
PTDEBUG && _d('Best index:', $best_index);
return $best_index;
}
sub _get_index_cardinality {
my (%args) = @_;
my @required_args = qw(Cxn tbl index);
my ($cxn, $tbl, $index) = @args{@required_args};
my $sql = "SHOW INDEXES FROM $tbl->{name} "
. "WHERE Key_name = '$index'";
PTDEBUG && _d($sql);
my $cardinality = 1;
my $dbh = $cxn->dbh();
my $key_name = $dbh && ($dbh->{FetchHashKeyName} || '') eq 'NAME_lc'
? 'key_name'
: 'Key_name';
my $rows = $dbh->selectall_hashref($sql, $key_name);
foreach my $row ( values %$rows ) {
$cardinality *= $row->{cardinality} if $row->{cardinality};
}
PTDEBUG && _d('Index', $index, 'cardinality:', $cardinality);
return $cardinality;
}
sub get_row_estimate {
my (%args) = @_;
my @required_args = qw(Cxn tbl);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn, $tbl) = @args{@required_args};
my $sql = "EXPLAIN SELECT * FROM $tbl->{name} "
. "WHERE " . ($args{where} || '1=1');
PTDEBUG && _d($sql);
my $expl = $cxn->dbh()->selectrow_hashref($sql);
PTDEBUG && _d(Dumper($expl));
my $mysql_index = $expl->{key} || '';
if ( $mysql_index ne 'PRIMARY' ) {
$mysql_index = lc($mysql_index);
}
return ($expl->{rows} || 0), $mysql_index;
}
sub _prepare_sths {
my ($self) = @_;
PTDEBUG && _d('Preparing statement handles');
my $dbh = $self->{Cxn}->dbh();
$self->{nibble_sth} = $dbh->prepare($self->{nibble_sql});
$self->{explain_nibble_sth} = $dbh->prepare($self->{explain_nibble_sql});
if ( !$self->{one_nibble} ) {
$self->{explain_first_lb_sth} = $dbh->prepare($self->{explain_first_lb_sql});
$self->{ub_sth} = $dbh->prepare($self->{ub_sql});
$self->{explain_ub_sth} = $dbh->prepare($self->{explain_ub_sql});
}
return;
}
sub _get_bounds {
my ($self) = @_;
if ( $self->{one_nibble} ) {
if ( $self->{resume} ) {
$self->{no_more_boundaries} = 1;
}
return;
}
my $dbh = $self->{Cxn}->dbh();
$self->{first_lower} = $dbh->selectrow_arrayref($self->{first_lb_sql});
PTDEBUG && _d('First lower boundary:', Dumper($self->{first_lower}));
if ( my $nibble = $self->{resume} ) {
if ( defined $nibble->{lower_boundary}
&& defined $nibble->{upper_boundary} ) {
my $sth = $dbh->prepare($self->{resume_lb_sql});
my @ub = split ',', $nibble->{upper_boundary};
PTDEBUG && _d($sth->{Statement}, 'params:', @ub);
$sth->execute(@ub);
$self->{next_lower} = $sth->fetchrow_arrayref();
$sth->finish();
}
}
else {
$self->{next_lower} = $self->{first_lower};
}
PTDEBUG && _d('Next lower boundary:', Dumper($self->{next_lower}));
if ( !$self->{next_lower} ) {
PTDEBUG && _d('At end of table, or no more boundaries to resume');
$self->{no_more_boundaries} = 1;
$self->{last_upper} = $dbh->selectrow_arrayref($self->{last_ub_sql});
PTDEBUG && _d('Last upper boundary:', Dumper($self->{last_upper}));
}
return;
}
sub _next_boundaries {
my ($self) = @_;
if ( $self->{no_more_boundaries} ) {
PTDEBUG && _d('No more boundaries');
return; # stop nibbling
}
if ( $self->{one_nibble} ) {
$self->{lower} = $self->{upper} = [];
$self->{no_more_boundaries} = 1; # for next call
return 1; # continue nibbling
}
if ( $self->identical_boundaries($self->{lower}, $self->{next_lower}) ) {
PTDEBUG && _d('Infinite loop detected');
my $tbl = $self->{tbl};
my $index = $tbl->{tbl_struct}->{keys}->{$self->{index}};
my $n_cols = scalar @{$index->{cols}};
my $chunkno = $self->{nibbleno};
die "Possible infinite loop detected! "
. "The lower boundary for chunk $chunkno is "
. "<" . join(', ', @{$self->{lower}}) . "> and the lower "
. "boundary for chunk " . ($chunkno + 1) . " is also "
. "<" . join(', ', @{$self->{next_lower}}) . ">. "
. "This usually happens when using a non-unique single "
. "column index. The current chunk index for table "
. "$tbl->{db}.$tbl->{tbl} is $self->{index} which is"
. ($index->{is_unique} ? '' : ' not') . " unique and covers "
. ($n_cols > 1 ? "$n_cols columns" : "1 column") . ".\n";
}
$self->{lower} = $self->{next_lower};
if ( my $callback = $self->{callbacks}->{next_boundaries} ) {
my $oktonibble = $callback->(
Cxn => $self->{Cxn},
tbl => $self->{tbl},
NibbleIterator => $self,
);
PTDEBUG && _d('next_boundaries callback returned', $oktonibble);
if ( !$oktonibble ) {
$self->{no_more_boundaries} = 1;
return; # stop nibbling
}
}
PTDEBUG && _d($self->{ub_sth}->{Statement}, 'params:',
join(', ', @{$self->{lower}}), $self->{limit});
$self->{ub_sth}->execute(@{$self->{lower}}, $self->{limit});
my $boundary = $self->{ub_sth}->fetchall_arrayref();
PTDEBUG && _d('Next boundary:', Dumper($boundary));
if ( $boundary && @$boundary ) {
$self->{upper} = $boundary->[0];
if ( $boundary->[1] ) {
$self->{next_lower} = $boundary->[1];
}
else {
PTDEBUG && _d('End of table boundary:', Dumper($boundary->[0]));
$self->{no_more_boundaries} = 1; # for next call
$self->{last_upper} = $boundary->[0];
}
}
else {
my $dbh = $self->{Cxn}->dbh();
$self->{upper} = $dbh->selectrow_arrayref($self->{last_ub_sql});
PTDEBUG && _d('Last upper boundary:', Dumper($self->{upper}));
$self->{no_more_boundaries} = 1; # for next call
$self->{last_upper} = $self->{upper};
}
$self->{ub_sth}->finish();
return 1; # continue nibbling
}
sub identical_boundaries {
my ($self, $b1, $b2) = @_;
return 0 if ($b1 && !$b2) || (!$b1 && $b2);
return 1 if !$b1 && !$b2;
die "Boundaries have different numbers of values"
if scalar @$b1 != scalar @$b2; # shouldn't happen
my $n_vals = scalar @$b1;
for my $i ( 0..($n_vals-1) ) {
return 0 if $b1->[$i] ne $b2->[$i]; # diff
}
return 1;
}
sub DESTROY {
my ( $self ) = @_;
foreach my $key ( keys %$self ) {
if ( $key =~ m/_sth$/ ) {
PTDEBUG && _d('Finish', $key);
$self->{$key}->finish();
}
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End NibbleIterator package
# ###########################################################################
# ###########################################################################
# Transformers package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Transformers.pm
# t/lib/Transformers.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Transformers;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Time::Local qw(timegm timelocal);
use Digest::MD5 qw(md5_hex);
use B qw();
BEGIN {
require Exporter;
our @ISA = qw(Exporter);
our %EXPORT_TAGS = ();
our @EXPORT = ();
our @EXPORT_OK = qw(
micro_t
percentage_of
secs_to_time
time_to_secs
shorten
ts
parse_timestamp
unix_timestamp
any_unix_timestamp
make_checksum
crc32
encode_json
);
}
our $mysql_ts = qr/(\d\d)(\d\d)(\d\d) +(\d+):(\d+):(\d+)(\.\d+)?/;
our $proper_ts = qr/(\d\d\d\d)-(\d\d)-(\d\d)[T ](\d\d):(\d\d):(\d\d)(\.\d+)?/;
our $n_ts = qr/(\d{1,5})([shmd]?)/; # Limit \d{1,5} because \d{6} looks
sub micro_t {
my ( $t, %args ) = @_;
my $p_ms = defined $args{p_ms} ? $args{p_ms} : 0; # precision for ms vals
my $p_s = defined $args{p_s} ? $args{p_s} : 0; # precision for s vals
my $f;
$t = 0 if $t < 0;
$t = sprintf('%.17f', $t) if $t =~ /e/;
$t =~ s/\.(\d{1,6})\d*/\.$1/;
if ($t > 0 && $t <= 0.000999) {
$f = ($t * 1000000) . 'us';
}
elsif ($t >= 0.001000 && $t <= 0.999999) {
$f = sprintf("%.${p_ms}f", $t * 1000);
$f = ($f * 1) . 'ms'; # * 1 to remove insignificant zeros
}
elsif ($t >= 1) {
$f = sprintf("%.${p_s}f", $t);
$f = ($f * 1) . 's'; # * 1 to remove insignificant zeros
}
else {
$f = 0; # $t should = 0 at this point
}
return $f;
}
sub percentage_of {
my ( $is, $of, %args ) = @_;
my $p = $args{p} || 0; # float precision
my $fmt = $p ? "%.${p}f" : "%d";
return sprintf $fmt, ($is * 100) / ($of ||= 1);
}
sub secs_to_time {
my ( $secs, $fmt ) = @_;
$secs ||= 0;
return '00:00' unless $secs;
$fmt ||= $secs >= 86_400 ? 'd'
: $secs >= 3_600 ? 'h'
: 'm';
return
$fmt eq 'd' ? sprintf(
"%d+%02d:%02d:%02d",
int($secs / 86_400),
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: $fmt eq 'h' ? sprintf(
"%02d:%02d:%02d",
int(($secs % 86_400) / 3_600),
int(($secs % 3_600) / 60),
$secs % 60)
: sprintf(
"%02d:%02d",
int(($secs % 3_600) / 60),
$secs % 60);
}
sub time_to_secs {
my ( $val, $default_suffix ) = @_;
die "I need a val argument" unless defined $val;
my $t = 0;
my ( $prefix, $num, $suffix ) = $val =~ m/([+-]?)(\d+)([a-z])?$/;
$suffix = $suffix || $default_suffix || 's';
if ( $suffix =~ m/[smhd]/ ) {
$t = $suffix eq 's' ? $num * 1 # Seconds
: $suffix eq 'm' ? $num * 60 # Minutes
: $suffix eq 'h' ? $num * 3600 # Hours
: $num * 86400; # Days
$t *= -1 if $prefix && $prefix eq '-';
}
else {
die "Invalid suffix for $val: $suffix";
}
return $t;
}
sub shorten {
my ( $num, %args ) = @_;
my $p = defined $args{p} ? $args{p} : 2; # float precision
my $d = defined $args{d} ? $args{d} : 1_024; # divisor
my $n = 0;
my @units = ('', qw(k M G T P E Z Y));
while ( $num >= $d && $n < @units - 1 ) {
$num /= $d;
++$n;
}
return sprintf(
$num =~ m/\./ || $n
? "%.${p}f%s"
: '%d',
$num, $units[$n]);
}
sub ts {
my ( $time, $gmt ) = @_;
my ( $sec, $min, $hour, $mday, $mon, $year )
= $gmt ? gmtime($time) : localtime($time);
$mon += 1;
$year += 1900;
my $val = sprintf("%d-%02d-%02dT%02d:%02d:%02d",
$year, $mon, $mday, $hour, $min, $sec);
if ( my ($us) = $time =~ m/(\.\d+)$/ ) {
$us = sprintf("%.6f", $us);
$us =~ s/^0\././;
$val .= $us;
}
return $val;
}
sub parse_timestamp {
my ( $val ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $f)
= $val =~ m/^$mysql_ts$/ )
{
return sprintf "%d-%02d-%02d %02d:%02d:"
. (defined $f ? '%09.6f' : '%02d'),
$y + 2000, $m, $d, $h, $i, (defined $f ? $s + $f : $s);
}
elsif ( $val =~ m/^$proper_ts$/ ) {
return $val;
}
return $val;
}
sub unix_timestamp {
my ( $val, $gmt ) = @_;
if ( my($y, $m, $d, $h, $i, $s, $us) = $val =~ m/^$proper_ts$/ ) {
$val = $gmt
? timegm($s, $i, $h, $d, $m - 1, $y)
: timelocal($s, $i, $h, $d, $m - 1, $y);
if ( defined $us ) {
$us = sprintf('%.6f', $us);
$us =~ s/^0\././;
$val .= $us;
}
}
return $val;
}
sub any_unix_timestamp {
my ( $val, $callback ) = @_;
if ( my ($n, $suffix) = $val =~ m/^$n_ts$/ ) {
$n = $suffix eq 's' ? $n # Seconds
: $suffix eq 'm' ? $n * 60 # Minutes
: $suffix eq 'h' ? $n * 3600 # Hours
: $suffix eq 'd' ? $n * 86400 # Days
: $n; # default: Seconds
PTDEBUG && _d('ts is now - N[shmd]:', $n);
return time - $n;
}
elsif ( $val =~ m/^\d{9,}/ ) {
PTDEBUG && _d('ts is already a unix timestamp');
return $val;
}
elsif ( my ($ymd, $hms) = $val =~ m/^(\d{6})(?:\s+(\d+:\d+:\d+))?/ ) {
PTDEBUG && _d('ts is MySQL slow log timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp(parse_timestamp($val));
}
elsif ( ($ymd, $hms) = $val =~ m/^(\d{4}-\d\d-\d\d)(?:[T ](\d+:\d+:\d+))?/) {
PTDEBUG && _d('ts is properly formatted timestamp');
$val .= ' 00:00:00' unless $hms;
return unix_timestamp($val);
}
else {
PTDEBUG && _d('ts is MySQL expression');
return $callback->($val) if $callback && ref $callback eq 'CODE';
}
PTDEBUG && _d('Unknown ts type:', $val);
return;
}
sub make_checksum {
my ( $val ) = @_;
my $checksum = uc substr(md5_hex($val), -16);
PTDEBUG && _d($checksum, 'checksum for', $val);
return $checksum;
}
sub crc32 {
my ( $string ) = @_;
return unless $string;
my $poly = 0xEDB88320;
my $crc = 0xFFFFFFFF;
foreach my $char ( split(//, $string) ) {
my $comp = ($crc ^ ord($char)) & 0xFF;
for ( 1 .. 8 ) {
$comp = $comp & 1 ? $poly ^ ($comp >> 1) : $comp >> 1;
}
$crc = (($crc >> 8) & 0x00FFFFFF) ^ $comp;
}
return $crc ^ 0xFFFFFFFF;
}
my $got_json = eval { require JSON };
sub encode_json {
return JSON::encode_json(@_) if $got_json;
my ( $data ) = @_;
return (object_to_json($data) || '');
}
sub object_to_json {
my ($obj) = @_;
my $type = ref($obj);
if($type eq 'HASH'){
return hash_to_json($obj);
}
elsif($type eq 'ARRAY'){
return array_to_json($obj);
}
else {
return value_to_json($obj);
}
}
sub hash_to_json {
my ($obj) = @_;
my @res;
for my $k ( sort { $a cmp $b } keys %$obj ) {
push @res, string_to_json( $k )
. ":"
. ( object_to_json( $obj->{$k} ) || value_to_json( $obj->{$k} ) );
}
return '{' . ( @res ? join( ",", @res ) : '' ) . '}';
}
sub array_to_json {
my ($obj) = @_;
my @res;
for my $v (@$obj) {
push @res, object_to_json($v) || value_to_json($v);
}
return '[' . ( @res ? join( ",", @res ) : '' ) . ']';
}
sub value_to_json {
my ($value) = @_;
return 'null' if(!defined $value);
my $b_obj = B::svref_2object(\$value); # for round trip problem
my $flags = $b_obj->FLAGS;
return $value # as is
if $flags & ( B::SVp_IOK | B::SVp_NOK ) and !( $flags & B::SVp_POK ); # SvTYPE is IV or NV?
my $type = ref($value);
if( !$type ) {
return string_to_json($value);
}
else {
return 'null';
}
}
my %esc = (
"\n" => '\n',
"\r" => '\r',
"\t" => '\t',
"\f" => '\f',
"\b" => '\b',
"\"" => '\"',
"\\" => '\\\\',
"\'" => '\\\'',
);
sub string_to_json {
my ($arg) = @_;
$arg =~ s/([\x22\x5c\n\r\t\f\b])/$esc{$1}/g;
$arg =~ s/\//\\\//g;
$arg =~ s/([\x00-\x08\x0b\x0e-\x1f])/'\\u00' . unpack('H2', $1)/eg;
utf8::upgrade($arg);
utf8::encode($arg);
return '"' . $arg . '"';
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Transformers package
# ###########################################################################
# ###########################################################################
# CleanupTask package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/CleanupTask.pm
# t/lib/CleanupTask.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package CleanupTask;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
sub new {
my ( $class, $task ) = @_;
die "I need a task parameter" unless $task;
die "The task parameter must be a coderef" unless ref $task eq 'CODE';
my $self = {
task => $task,
};
open $self->{stdout_copy}, ">&=", *STDOUT
or die "Cannot dup stdout: $OS_ERROR";
open $self->{stderr_copy}, ">&=", *STDERR
or die "Cannot dup stderr: $OS_ERROR";
PTDEBUG && _d('Created cleanup task', $task);
return bless $self, $class;
}
sub DESTROY {
my ($self) = @_;
my $task = $self->{task};
if ( ref $task ) {
PTDEBUG && _d('Calling cleanup task', $task);
open local(*STDOUT), ">&=", $self->{stdout_copy}
if $self->{stdout_copy};
open local(*STDERR), ">&=", $self->{stderr_copy}
if $self->{stderr_copy};
$task->();
}
else {
warn "Lost cleanup task";
}
return;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End CleanupTask package
# ###########################################################################
# ###########################################################################
# IndexLength package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/IndexLength.pm
# t/lib/IndexLength.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package IndexLength;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
sub new {
my ( $class, %args ) = @_;
my @required_args = qw(Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $self = {
Quoter => $args{Quoter},
};
return bless $self, $class;
}
sub index_length {
my ($self, %args) = @_;
my @required_args = qw(Cxn tbl index);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn) = @args{@required_args};
die "The tbl argument does not have a tbl_struct"
unless exists $args{tbl}->{tbl_struct};
die "Index $args{index} does not exist in table $args{tbl}->{name}"
unless $args{tbl}->{tbl_struct}->{keys}->{$args{index}};
my $index_struct = $args{tbl}->{tbl_struct}->{keys}->{$args{index}};
my $index_cols = $index_struct->{cols};
my $n_index_cols = $args{n_index_cols};
if ( !$n_index_cols || $n_index_cols > @$index_cols ) {
$n_index_cols = scalar @$index_cols;
}
my $vals = $self->_get_first_values(
%args,
n_index_cols => $n_index_cols,
);
my $sql = $self->_make_range_query(
%args,
n_index_cols => $n_index_cols,
vals => $vals,
);
my $sth = $cxn->dbh()->prepare($sql);
PTDEBUG && _d($sth->{Statement}, 'params:', @$vals);
$sth->execute(@$vals);
my $row = $sth->fetchrow_hashref();
$sth->finish();
PTDEBUG && _d('Range scan:', Dumper($row));
return $row->{key_len}, $row->{key};
}
sub _get_first_values {
my ($self, %args) = @_;
my @required_args = qw(Cxn tbl index n_index_cols);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn, $tbl, $index, $n_index_cols) = @args{@required_args};
my $q = $self->{Quoter};
my $index_struct = $tbl->{tbl_struct}->{keys}->{$index};
my $index_cols = $index_struct->{cols};
my $index_columns = join (', ',
map { $q->quote($_) } @{$index_cols}[0..($n_index_cols - 1)]);
my @where;
foreach my $col ( @{$index_cols}[0..($n_index_cols - 1)] ) {
push @where, $q->quote($col) . " IS NOT NULL"
}
my $sql = "SELECT /*!40001 SQL_NO_CACHE */ $index_columns "
. "FROM $tbl->{name} FORCE INDEX (" . $q->quote($index) . ") "
. "WHERE " . join(' AND ', @where)
. " ORDER BY $index_columns "
. "LIMIT 1 /*key_len*/"; # only need 1 row
PTDEBUG && _d($sql);
my $vals = $cxn->dbh()->selectrow_arrayref($sql);
return $vals;
}
sub _make_range_query {
my ($self, %args) = @_;
my @required_args = qw(tbl index n_index_cols vals);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($tbl, $index, $n_index_cols, $vals) = @args{@required_args};
my $q = $self->{Quoter};
my $index_struct = $tbl->{tbl_struct}->{keys}->{$index};
my $index_cols = $index_struct->{cols};
my @where;
if ( $n_index_cols > 1 ) {
foreach my $n ( 0..($n_index_cols - 2) ) {
my $col = $index_cols->[$n];
my $val = $vals->[$n];
push @where, $q->quote($col) . " = ?";
}
}
my $col = $index_cols->[$n_index_cols - 1];
my $val = $vals->[-1]; # should only be as many vals as cols
push @where, $q->quote($col) . " >= ?";
my $sql = "EXPLAIN SELECT /*!40001 SQL_NO_CACHE */ * "
. "FROM $tbl->{name} FORCE INDEX (" . $q->quote($index) . ") "
. "WHERE " . join(' AND ', @where)
. " /*key_len*/";
return $sql;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End IndexLength package
# ###########################################################################
# ###########################################################################
# HTTP::Micro package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/HTTP/Micro.pm
# t/lib/HTTP/Micro.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package HTTP::Micro;
our $VERSION = '0.01';
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp ();
my @attributes;
BEGIN {
@attributes = qw(agent timeout);
no strict 'refs';
for my $accessor ( @attributes ) {
*{$accessor} = sub {
@_ > 1 ? $_[0]->{$accessor} = $_[1] : $_[0]->{$accessor};
};
}
}
sub new {
my($class, %args) = @_;
(my $agent = $class) =~ s{::}{-}g;
my $self = {
agent => $agent . "/" . ($class->VERSION || 0),
timeout => 60,
};
for my $key ( @attributes ) {
$self->{$key} = $args{$key} if exists $args{$key}
}
return bless $self, $class;
}
my %DefaultPort = (
http => 80,
https => 443,
);
sub request {
my ($self, $method, $url, $args) = @_;
@_ == 3 || (@_ == 4 && ref $args eq 'HASH')
or Carp::croak(q/Usage: $http->request(METHOD, URL, [HASHREF])/);
$args ||= {}; # we keep some state in this during _request
my $response;
for ( 0 .. 1 ) {
$response = eval { $self->_request($method, $url, $args) };
last unless $@ && $method eq 'GET'
&& $@ =~ m{^(?:Socket closed|Unexpected end)};
}
if (my $e = "$@") {
$response = {
success => q{},
status => 599,
reason => 'Internal Exception',
content => $e,
headers => {
'content-type' => 'text/plain',
'content-length' => length $e,
}
};
}
return $response;
}
sub _request {
my ($self, $method, $url, $args) = @_;
my ($scheme, $host, $port, $path_query) = $self->_split_url($url);
my $request = {
method => $method,
scheme => $scheme,
host_port => ($port == $DefaultPort{$scheme} ? $host : "$host:$port"),
uri => $path_query,
headers => {},
};
my $handle = HTTP::Micro::Handle->new(timeout => $self->{timeout});
$handle->connect($scheme, $host, $port);
$self->_prepare_headers_and_cb($request, $args);
$handle->write_request_header(@{$request}{qw/method uri headers/});
$handle->write_content_body($request) if $request->{content};
my $response;
do { $response = $handle->read_response_header }
until (substr($response->{status},0,1) ne '1');
if (!($method eq 'HEAD' || $response->{status} =~ /^[23]04/)) {
$response->{content} = '';
$handle->read_content_body(sub { $_[1]->{content} .= $_[0] }, $response);
}
$handle->close;
$response->{success} = substr($response->{status},0,1) eq '2';
return $response;
}
sub _prepare_headers_and_cb {
my ($self, $request, $args) = @_;
for ($args->{headers}) {
next unless defined;
while (my ($k, $v) = each %$_) {
$request->{headers}{lc $k} = $v;
}
}
$request->{headers}{'host'} = $request->{host_port};
$request->{headers}{'connection'} = "close";
$request->{headers}{'user-agent'} ||= $self->{agent};
if (defined $args->{content}) {
$request->{headers}{'content-type'} ||= "application/octet-stream";
utf8::downgrade($args->{content}, 1)
or Carp::croak(q/Wide character in request message body/);
$request->{headers}{'content-length'} = length $args->{content};
$request->{content} = $args->{content};
}
return;
}
sub _split_url {
my $url = pop;
my ($scheme, $authority, $path_query) = $url =~ m<\A([^:/?#]+)://([^/?#]*)([^#]*)>
or Carp::croak(qq/Cannot parse URL: '$url'/);
$scheme = lc $scheme;
$path_query = "/$path_query" unless $path_query =~ m<\A/>;
my $host = (length($authority)) ? lc $authority : 'localhost';
$host =~ s/\A[^@]*@//; # userinfo
my $port = do {
$host =~ s/:([0-9]*)\z// && length $1
? $1
: $DefaultPort{$scheme}
};
return ($scheme, $host, $port, $path_query);
}
} # HTTP::Micro
{
package HTTP::Micro::Handle;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Carp qw(croak);
use Errno qw(EINTR EPIPE);
use IO::Socket qw(SOCK_STREAM);
sub BUFSIZE () { 32768 }
my $Printable = sub {
local $_ = shift;
s/\r/\\r/g;
s/\n/\\n/g;
s/\t/\\t/g;
s/([^\x20-\x7E])/sprintf('\\x%.2X', ord($1))/ge;
$_;
};
sub new {
my ($class, %args) = @_;
return bless {
rbuf => '',
timeout => 60,
max_line_size => 16384,
%args
}, $class;
}
my $ssl_verify_args = {
check_cn => "when_only",
wildcards_in_alt => "anywhere",
wildcards_in_cn => "anywhere"
};
sub connect {
@_ == 4 || croak(q/Usage: $handle->connect(scheme, host, port)/);
my ($self, $scheme, $host, $port) = @_;
if ( $scheme eq 'https' ) {
eval "require IO::Socket::SSL"
unless exists $INC{'IO/Socket/SSL.pm'};
croak(qq/IO::Socket::SSL must be installed for https support\n/)
unless $INC{'IO/Socket/SSL.pm'};
}
elsif ( $scheme ne 'http' ) {
croak(qq/Unsupported URL scheme '$scheme'\n/);
}
$self->{fh} = IO::Socket::INET->new(
PeerHost => $host,
PeerPort => $port,
Proto => 'tcp',
Type => SOCK_STREAM,
Timeout => $self->{timeout}
) or croak(qq/Could not connect to '$host:$port': $@/);
binmode($self->{fh})
or croak(qq/Could not binmode() socket: '$!'/);
if ( $scheme eq 'https') {
IO::Socket::SSL->start_SSL($self->{fh});
ref($self->{fh}) eq 'IO::Socket::SSL'
or die(qq/SSL connection failed for $host\n/);
if ( $self->{fh}->can("verify_hostname") ) {
$self->{fh}->verify_hostname( $host, $ssl_verify_args )
or die(qq/SSL certificate not valid for $host\n/);
}
else {
my $fh = $self->{fh};
_verify_hostname_of_cert($host, _peer_certificate($fh), $ssl_verify_args)
or die(qq/SSL certificate not valid for $host\n/);
}
}
$self->{host} = $host;
$self->{port} = $port;
return $self;
}
sub close {
@_ == 1 || croak(q/Usage: $handle->close()/);
my ($self) = @_;
CORE::close($self->{fh})
or croak(qq/Could not close socket: '$!'/);
}
sub write {
@_ == 2 || croak(q/Usage: $handle->write(buf)/);
my ($self, $buf) = @_;
my $len = length $buf;
my $off = 0;
local $SIG{PIPE} = 'IGNORE';
while () {
$self->can_write
or croak(q/Timed out while waiting for socket to become ready for writing/);
my $r = syswrite($self->{fh}, $buf, $len, $off);
if (defined $r) {
$len -= $r;
$off += $r;
last unless $len > 0;
}
elsif ($! == EPIPE) {
croak(qq/Socket closed by remote server: $!/);
}
elsif ($! != EINTR) {
croak(qq/Could not write to socket: '$!'/);
}
}
return $off;
}
sub read {
@_ == 2 || @_ == 3 || croak(q/Usage: $handle->read(len)/);
my ($self, $len) = @_;
my $buf = '';
my $got = length $self->{rbuf};
if ($got) {
my $take = ($got < $len) ? $got : $len;
$buf = substr($self->{rbuf}, 0, $take, '');
$len -= $take;
}
while ($len > 0) {
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $buf, $len, length $buf);
if (defined $r) {
last unless $r;
$len -= $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
if ($len) {
croak(q/Unexpected end of stream/);
}
return $buf;
}
sub readline {
@_ == 1 || croak(q/Usage: $handle->readline()/);
my ($self) = @_;
while () {
if ($self->{rbuf} =~ s/\A ([^\x0D\x0A]* \x0D?\x0A)//x) {
return $1;
}
$self->can_read
or croak(q/Timed out while waiting for socket to become ready for reading/);
my $r = sysread($self->{fh}, $self->{rbuf}, BUFSIZE, length $self->{rbuf});
if (defined $r) {
last unless $r;
}
elsif ($! != EINTR) {
croak(qq/Could not read from socket: '$!'/);
}
}
croak(q/Unexpected end of stream while looking for line/);
}
sub read_header_lines {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->read_header_lines([headers])/);
my ($self, $headers) = @_;
$headers ||= {};
my $lines = 0;
my $val;
while () {
my $line = $self->readline;
if ($line =~ /\A ([^\x00-\x1F\x7F:]+) : [\x09\x20]* ([^\x0D\x0A]*)/x) {
my ($field_name) = lc $1;
$val = \($headers->{$field_name} = $2);
}
elsif ($line =~ /\A [\x09\x20]+ ([^\x0D\x0A]*)/x) {
$val
or croak(q/Unexpected header continuation line/);
next unless length $1;
$$val .= ' ' if length $$val;
$$val .= $1;
}
elsif ($line =~ /\A \x0D?\x0A \z/x) {
last;
}
else {
croak(q/Malformed header line: / . $Printable->($line));
}
}
return $headers;
}
sub write_header_lines {
(@_ == 2 && ref $_[1] eq 'HASH') || croak(q/Usage: $handle->write_header_lines(headers)/);
my($self, $headers) = @_;
my $buf = '';
while (my ($k, $v) = each %$headers) {
my $field_name = lc $k;
$field_name =~ /\A [\x21\x23-\x27\x2A\x2B\x2D\x2E\x30-\x39\x41-\x5A\x5E-\x7A\x7C\x7E]+ \z/x
or croak(q/Invalid HTTP header field name: / . $Printable->($field_name));
$field_name =~ s/\b(\w)/\u$1/g;
$buf .= "$field_name: $v\x0D\x0A";
}
$buf .= "\x0D\x0A";
return $self->write($buf);
}
sub read_content_body {
@_ == 3 || @_ == 4 || croak(q/Usage: $handle->read_content_body(callback, response, [read_length])/);
my ($self, $cb, $response, $len) = @_;
$len ||= $response->{headers}{'content-length'};
croak("No content-length in the returned response, and this "
. "UA doesn't implement chunking") unless defined $len;
while ($len > 0) {
my $read = ($len > BUFSIZE) ? BUFSIZE : $len;
$cb->($self->read($read), $response);
$len -= $read;
}
return;
}
sub write_content_body {
@_ == 2 || croak(q/Usage: $handle->write_content_body(request)/);
my ($self, $request) = @_;
my ($len, $content_length) = (0, $request->{headers}{'content-length'});
$len += $self->write($request->{content});
$len == $content_length
or croak(qq/Content-Length missmatch (got: $len expected: $content_length)/);
return $len;
}
sub read_response_header {
@_ == 1 || croak(q/Usage: $handle->read_response_header()/);
my ($self) = @_;
my $line = $self->readline;
$line =~ /\A (HTTP\/(0*\d+\.0*\d+)) [\x09\x20]+ ([0-9]{3}) [\x09\x20]+ ([^\x0D\x0A]*) \x0D?\x0A/x
or croak(q/Malformed Status-Line: / . $Printable->($line));
my ($protocol, $version, $status, $reason) = ($1, $2, $3, $4);
return {
status => $status,
reason => $reason,
headers => $self->read_header_lines,
protocol => $protocol,
};
}
sub write_request_header {
@_ == 4 || croak(q/Usage: $handle->write_request_header(method, request_uri, headers)/);
my ($self, $method, $request_uri, $headers) = @_;
return $self->write("$method $request_uri HTTP/1.1\x0D\x0A")
+ $self->write_header_lines($headers);
}
sub _do_timeout {
my ($self, $type, $timeout) = @_;
$timeout = $self->{timeout}
unless defined $timeout && $timeout >= 0;
my $fd = fileno $self->{fh};
defined $fd && $fd >= 0
or croak(q/select(2): 'Bad file descriptor'/);
my $initial = time;
my $pending = $timeout;
my $nfound;
vec(my $fdset = '', $fd, 1) = 1;
while () {
$nfound = ($type eq 'read')
? select($fdset, undef, undef, $pending)
: select(undef, $fdset, undef, $pending) ;
if ($nfound == -1) {
$! == EINTR
or croak(qq/select(2): '$!'/);
redo if !$timeout || ($pending = $timeout - (time - $initial)) > 0;
$nfound = 0;
}
last;
}
$! = 0;
return $nfound;
}
sub can_read {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_read([timeout])/);
my $self = shift;
return $self->_do_timeout('read', @_)
}
sub can_write {
@_ == 1 || @_ == 2 || croak(q/Usage: $handle->can_write([timeout])/);
my $self = shift;
return $self->_do_timeout('write', @_)
}
} # HTTP::Micro::Handle
my $prog = <<'EOP';
BEGIN {
if ( defined &IO::Socket::SSL::CAN_IPV6 ) {
*CAN_IPV6 = \*IO::Socket::SSL::CAN_IPV6;
}
else {
constant->import( CAN_IPV6 => '' );
}
my %const = (
NID_CommonName => 13,
GEN_DNS => 2,
GEN_IPADD => 7,
);
while ( my ($name,$value) = each %const ) {
no strict 'refs';
*{$name} = UNIVERSAL::can( 'Net::SSLeay', $name ) || sub { $value };
}
}
{
use Carp qw(croak);
my %dispatcher = (
issuer => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_issuer_name( shift )) },
subject => sub { Net::SSLeay::X509_NAME_oneline( Net::SSLeay::X509_get_subject_name( shift )) },
);
if ( $Net::SSLeay::VERSION >= 1.30 ) {
$dispatcher{commonName} = sub {
my $cn = Net::SSLeay::X509_NAME_get_text_by_NID(
Net::SSLeay::X509_get_subject_name( shift ), NID_CommonName);
$cn =~s{\0$}{}; # work around Bug in Net::SSLeay <1.33
$cn;
}
} else {
$dispatcher{commonName} = sub {
croak "you need at least Net::SSLeay version 1.30 for getting commonName"
}
}
if ( $Net::SSLeay::VERSION >= 1.33 ) {
$dispatcher{subjectAltNames} = sub { Net::SSLeay::X509_get_subjectAltNames( shift ) };
} else {
$dispatcher{subjectAltNames} = sub {
return;
};
}
$dispatcher{authority} = $dispatcher{issuer};
$dispatcher{owner} = $dispatcher{subject};
$dispatcher{cn} = $dispatcher{commonName};
sub _peer_certificate {
my ($self, $field) = @_;
my $ssl = $self->_get_ssl_object or return;
my $cert = ${*$self}{_SSL_certificate}
||= Net::SSLeay::get_peer_certificate($ssl)
or return $self->error("Could not retrieve peer certificate");
if ($field) {
my $sub = $dispatcher{$field} or croak
"invalid argument for peer_certificate, valid are: ".join( " ",keys %dispatcher ).
"\nMaybe you need to upgrade your Net::SSLeay";
return $sub->($cert);
} else {
return $cert
}
}
my %scheme = (
ldap => {
wildcards_in_cn => 0,
wildcards_in_alt => 'leftmost',
check_cn => 'always',
},
http => {
wildcards_in_cn => 'anywhere',
wildcards_in_alt => 'anywhere',
check_cn => 'when_only',
},
smtp => {
wildcards_in_cn => 0,
wildcards_in_alt => 0,
check_cn => 'always'
},
none => {}, # do not check
);
$scheme{www} = $scheme{http}; # alias
$scheme{xmpp} = $scheme{http}; # rfc 3920
$scheme{pop3} = $scheme{ldap}; # rfc 2595
$scheme{imap} = $scheme{ldap}; # rfc 2595
$scheme{acap} = $scheme{ldap}; # rfc 2595
$scheme{nntp} = $scheme{ldap}; # rfc 4642
$scheme{ftp} = $scheme{http}; # rfc 4217
sub _verify_hostname_of_cert {
my $identity = shift;
my $cert = shift;
my $scheme = shift || 'none';
if ( ! ref($scheme) ) {
$scheme = $scheme{$scheme} or croak "scheme $scheme not defined";
}
return 1 if ! %$scheme; # 'none'
my $commonName = $dispatcher{cn}->($cert);
my @altNames = $dispatcher{subjectAltNames}->($cert);
if ( my $sub = $scheme->{callback} ) {
return $sub->($identity,$commonName,@altNames);
}
my $ipn;
if ( CAN_IPV6 and $identity =~m{:} ) {
$ipn = IO::Socket::SSL::inet_pton(IO::Socket::SSL::AF_INET6,$identity)
or croak "'$identity' is not IPv6, but neither IPv4 nor hostname";
} elsif ( $identity =~m{^\d+\.\d+\.\d+\.\d+$} ) {
$ipn = IO::Socket::SSL::inet_aton( $identity ) or croak "'$identity' is not IPv4, but neither IPv6 nor hostname";
} else {
if ( $identity =~m{[^a-zA-Z0-9_.\-]} ) {
$identity =~m{\0} and croak("name '$identity' has \\0 byte");
$identity = IO::Socket::SSL::idn_to_ascii($identity) or
croak "Warning: Given name '$identity' could not be converted to IDNA!";
}
}
my $check_name = sub {
my ($name,$identity,$wtyp) = @_;
$wtyp ||= '';
my $pattern;
if ( $wtyp eq 'anywhere' and $name =~m{^([a-zA-Z0-9_\-]*)\*(.+)} ) {
$pattern = qr{^\Q$1\E[a-zA-Z0-9_\-]*\Q$2\E$}i;
} elsif ( $wtyp eq 'leftmost' and $name =~m{^\*(\..+)$} ) {
$pattern = qr{^[a-zA-Z0-9_\-]*\Q$1\E$}i;
} else {
$pattern = qr{^\Q$name\E$}i;
}
return $identity =~ $pattern;
};
my $alt_dnsNames = 0;
while (@altNames) {
my ($type, $name) = splice (@altNames, 0, 2);
if ( $ipn and $type == GEN_IPADD ) {
return 1 if $ipn eq $name;
} elsif ( ! $ipn and $type == GEN_DNS ) {
$name =~s/\s+$//; $name =~s/^\s+//;
$alt_dnsNames++;
$check_name->($name,$identity,$scheme->{wildcards_in_alt})
and return 1;
}
}
if ( ! $ipn and (
$scheme->{check_cn} eq 'always' or
$scheme->{check_cn} eq 'when_only' and !$alt_dnsNames)) {
$check_name->($commonName,$identity,$scheme->{wildcards_in_cn})
and return 1;
}
return 0; # no match
}
}
EOP
eval { require IO::Socket::SSL };
if ( $INC{"IO/Socket/SSL.pm"} ) {
eval $prog;
die $@ if $@;
}
1;
# ###########################################################################
# End HTTP::Micro package
# ###########################################################################
# ###########################################################################
# VersionCheck package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/VersionCheck.pm
# t/lib/VersionCheck.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package VersionCheck;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Data::Dumper;
local $Data::Dumper::Indent = 1;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Quotekeys = 0;
use Digest::MD5 qw(md5_hex);
use Sys::Hostname qw(hostname);
use File::Basename qw();
use File::Spec;
use FindBin qw();
eval {
require Percona::Toolkit;
require HTTP::Micro;
};
{
my $file = 'percona-version-check';
my $home = $ENV{HOME} || $ENV{HOMEPATH} || $ENV{USERPROFILE} || '.';
my @vc_dirs = (
'/etc/percona',
'/etc/percona-toolkit',
'/tmp',
"$home",
);
sub version_check_file {
foreach my $dir ( @vc_dirs ) {
if ( -d $dir && -w $dir ) {
PTDEBUG && _d('Version check file', $file, 'in', $dir);
return $dir . '/' . $file;
}
}
PTDEBUG && _d('Version check file', $file, 'in', $ENV{PWD});
return $file; # in the CWD
}
}
sub version_check_time_limit {
return 60 * 60 * 24; # one day
}
sub version_check {
my (%args) = @_;
my $instances = $args{instances} || [];
my $instances_to_check;
PTDEBUG && _d('FindBin::Bin:', $FindBin::Bin);
if ( !$args{force} ) {
if ( $FindBin::Bin
&& (-d "$FindBin::Bin/../.bzr" ||
-d "$FindBin::Bin/../../.bzr" ||
-d "$FindBin::Bin/../.git" ||
-d "$FindBin::Bin/../../.git"
)
) {
PTDEBUG && _d("$FindBin::Bin/../.bzr disables --version-check");
return;
}
}
eval {
foreach my $instance ( @$instances ) {
my ($name, $id) = get_instance_id($instance);
$instance->{name} = $name;
$instance->{id} = $id;
}
push @$instances, { name => 'system', id => 0 };
$instances_to_check = get_instances_to_check(
instances => $instances,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
PTDEBUG && _d(scalar @$instances_to_check, 'instances to check');
return unless @$instances_to_check;
my $protocol = 'https';
eval { require IO::Socket::SSL; };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
PTDEBUG && _d("SSL not available, won't run version_check");
return;
}
PTDEBUG && _d('Using', $protocol);
my $advice = pingback(
instances => $instances_to_check,
protocol => $protocol,
url => $args{url} # testing
|| $ENV{PERCONA_VERSION_CHECK_URL} # testing
|| "$protocol://v.percona.com",
);
if ( $advice ) {
PTDEBUG && _d('Advice:', Dumper($advice));
if ( scalar @$advice > 1) {
print "\n# " . scalar @$advice . " software updates are "
. "available:\n";
}
else {
print "\n# A software update is available:\n";
}
print join("\n", map { "# * $_" } @$advice), "\n\n";
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Version check failed:', $EVAL_ERROR);
}
if ( @$instances_to_check ) {
eval {
update_check_times(
instances => $instances_to_check,
vc_file => $args{vc_file}, # testing
now => $args{now}, # testing
);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error updating version check file:', $EVAL_ERROR);
}
}
if ( $ENV{PTDEBUG_VERSION_CHECK} ) {
warn "Exiting because the PTDEBUG_VERSION_CHECK "
. "environment variable is defined.\n";
exit 255;
}
return;
}
sub get_instances_to_check {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
if ( !-f $vc_file ) {
PTDEBUG && _d('Version check file', $vc_file, 'does not exist;',
'version checking all instances');
return $instances;
}
open my $fh, '<', $vc_file or die "Cannot open $vc_file: $OS_ERROR";
chomp(my $file_contents = do { local $/ = undef; <$fh> });
PTDEBUG && _d('Version check file', $vc_file, 'contents:', $file_contents);
close $fh;
my %last_check_time_for = $file_contents =~ /^([^,]+),(.+)$/mg;
my $check_time_limit = version_check_time_limit();
my @instances_to_check;
foreach my $instance ( @$instances ) {
my $last_check_time = $last_check_time_for{ $instance->{id} };
PTDEBUG && _d('Intsance', $instance->{id}, 'last checked',
$last_check_time, 'now', $now, 'diff', $now - ($last_check_time || 0),
'hours until next check',
sprintf '%.2f',
($check_time_limit - ($now - ($last_check_time || 0))) / 3600);
if ( !defined $last_check_time
|| ($now - $last_check_time) >= $check_time_limit ) {
PTDEBUG && _d('Time to check', Dumper($instance));
push @instances_to_check, $instance;
}
}
return \@instances_to_check;
}
sub update_check_times {
my (%args) = @_;
my $instances = $args{instances};
my $now = $args{now} || int(time);
my $vc_file = $args{vc_file} || version_check_file();
PTDEBUG && _d('Updating last check time:', $now);
my %all_instances = map {
$_->{id} => { name => $_->{name}, ts => $now }
} @$instances;
if ( -f $vc_file ) {
open my $fh, '<', $vc_file or die "Cannot read $vc_file: $OS_ERROR";
my $contents = do { local $/ = undef; <$fh> };
close $fh;
foreach my $line ( split("\n", ($contents || '')) ) {
my ($id, $ts) = split(',', $line);
if ( !exists $all_instances{$id} ) {
$all_instances{$id} = { ts => $ts }; # original ts, not updated
}
}
}
open my $fh, '>', $vc_file or die "Cannot write to $vc_file: $OS_ERROR";
foreach my $id ( sort keys %all_instances ) {
PTDEBUG && _d('Updated:', $id, Dumper($all_instances{$id}));
print { $fh } $id . ',' . $all_instances{$id}->{ts} . "\n";
}
close $fh;
return;
}
sub get_instance_id {
my ($instance) = @_;
my $dbh = $instance->{dbh};
my $dsn = $instance->{dsn};
my $sql = q{SELECT CONCAT(@@hostname, @@port)};
PTDEBUG && _d($sql);
my ($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$sql = q{SELECT @@hostname};
PTDEBUG && _d($sql);
($name) = eval { $dbh->selectrow_array($sql) };
if ( $EVAL_ERROR ) {
PTDEBUG && _d($EVAL_ERROR);
$name = ($dsn->{h} || 'localhost') . ($dsn->{P} || 3306);
}
else {
$sql = q{SHOW VARIABLES LIKE 'port'};
PTDEBUG && _d($sql);
my (undef, $port) = eval { $dbh->selectrow_array($sql) };
PTDEBUG && _d('port:', $port);
$name .= $port || '';
}
}
my $id = md5_hex($name);
PTDEBUG && _d('MySQL instance:', $id, $name, Dumper($dsn));
return $name, $id;
}
sub pingback {
my (%args) = @_;
my @required_args = qw(url instances);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my $url = $args{url};
my $instances = $args{instances};
my $ua = $args{ua} || HTTP::Micro->new( timeout => 3 );
my $response = $ua->request('GET', $url);
PTDEBUG && _d('Server response:', Dumper($response));
die "No response from GET $url"
if !$response;
die("GET on $url returned HTTP status $response->{status}; expected 200\n",
($response->{content} || '')) if $response->{status} != 200;
die("GET on $url did not return any programs to check")
if !$response->{content};
my $items = parse_server_response(
response => $response->{content}
);
die "Failed to parse server requested programs: $response->{content}"
if !scalar keys %$items;
my $versions = get_versions(
items => $items,
instances => $instances,
);
die "Failed to get any program versions; should have at least gotten Perl"
if !scalar keys %$versions;
my $client_content = encode_client_response(
items => $items,
versions => $versions,
general_id => md5_hex( hostname() ),
);
my $client_response = {
headers => { "X-Percona-Toolkit-Tool" => File::Basename::basename($0) },
content => $client_content,
};
PTDEBUG && _d('Client response:', Dumper($client_response));
$response = $ua->request('POST', $url, $client_response);
PTDEBUG && _d('Server suggestions:', Dumper($response));
die "No response from POST $url $client_response"
if !$response;
die "POST $url returned HTTP status $response->{status}; expected 200"
if $response->{status} != 200;
return unless $response->{content};
$items = parse_server_response(
response => $response->{content},
split_vars => 0,
);
die "Failed to parse server suggestions: $response->{content}"
if !scalar keys %$items;
my @suggestions = map { $_->{vars} }
sort { $a->{item} cmp $b->{item} }
values %$items;
return \@suggestions;
}
sub encode_client_response {
my (%args) = @_;
my @required_args = qw(items versions general_id);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items, $versions, $general_id) = @args{@required_args};
my @lines;
foreach my $item ( sort keys %$items ) {
next unless exists $versions->{$item};
if ( ref($versions->{$item}) eq 'HASH' ) {
my $mysql_versions = $versions->{$item};
for my $id ( sort keys %$mysql_versions ) {
push @lines, join(';', $id, $item, $mysql_versions->{$id});
}
}
else {
push @lines, join(';', $general_id, $item, $versions->{$item});
}
}
my $client_response = join("\n", @lines) . "\n";
return $client_response;
}
sub parse_server_response {
my (%args) = @_;
my @required_args = qw(response);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($response) = @args{@required_args};
my %items = map {
my ($item, $type, $vars) = split(";", $_);
if ( !defined $args{split_vars} || $args{split_vars} ) {
$vars = [ split(",", ($vars || '')) ];
}
$item => {
item => $item,
type => $type,
vars => $vars,
};
} split("\n", $response);
PTDEBUG && _d('Items:', Dumper(\%items));
return \%items;
}
my %sub_for_type = (
os_version => \&get_os_version,
perl_version => \&get_perl_version,
perl_module_version => \&get_perl_module_version,
mysql_variable => \&get_mysql_variable,
);
sub valid_item {
my ($item) = @_;
return unless $item;
if ( !exists $sub_for_type{ $item->{type} } ) {
PTDEBUG && _d('Invalid type:', $item->{type});
return 0;
}
return 1;
}
sub get_versions {
my (%args) = @_;
my @required_args = qw(items);
foreach my $arg ( @required_args ) {
die "I need a $arg arugment" unless $args{$arg};
}
my ($items) = @args{@required_args};
my %versions;
foreach my $item ( values %$items ) {
next unless valid_item($item);
eval {
my $version = $sub_for_type{ $item->{type} }->(
item => $item,
instances => $args{instances},
);
if ( $version ) {
chomp $version unless ref($version);
$versions{$item->{item}} = $version;
}
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Error getting version for', Dumper($item), $EVAL_ERROR);
}
}
return \%versions;
}
sub get_os_version {
if ( $OSNAME eq 'MSWin32' ) {
require Win32;
return Win32::GetOSDisplayName();
}
chomp(my $platform = `uname -s`);
PTDEBUG && _d('platform:', $platform);
return $OSNAME unless $platform;
chomp(my $lsb_release
= `which lsb_release 2>/dev/null | awk '{print \$1}'` || '');
PTDEBUG && _d('lsb_release:', $lsb_release);
my $release = "";
if ( $platform eq 'Linux' ) {
if ( -f "/etc/fedora-release" ) {
$release = `cat /etc/fedora-release`;
}
elsif ( -f "/etc/redhat-release" ) {
$release = `cat /etc/redhat-release`;
}
elsif ( -f "/etc/system-release" ) {
$release = `cat /etc/system-release`;
}
elsif ( $lsb_release ) {
$release = `$lsb_release -ds`;
}
elsif ( -f "/etc/lsb-release" ) {
$release = `grep DISTRIB_DESCRIPTION /etc/lsb-release`;
$release =~ s/^\w+="([^"]+)".+/$1/;
}
elsif ( -f "/etc/debian_version" ) {
chomp(my $rel = `cat /etc/debian_version`);
$release = "Debian $rel";
if ( -f "/etc/apt/sources.list" ) {
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}'`);
$release .= " ($code_name)" if $code_name;
}
}
elsif ( -f "/etc/os-release" ) { # openSUSE
chomp($release = `grep PRETTY_NAME /etc/os-release`);
$release =~ s/^PRETTY_NAME="(.+)"$/$1/;
}
elsif ( `ls /etc/*release 2>/dev/null` ) {
if ( `grep DISTRIB_DESCRIPTION /etc/*release 2>/dev/null` ) {
$release = `grep DISTRIB_DESCRIPTION /etc/*release | head -n1`;
}
else {
$release = `cat /etc/*release | head -n1`;
}
}
}
elsif ( $platform =~ m/(?:BSD|^Darwin)$/ ) {
my $rel = `uname -r`;
$release = "$platform $rel";
}
elsif ( $platform eq "SunOS" ) {
my $rel = `head -n1 /etc/release` || `uname -r`;
$release = "$platform $rel";
}
if ( !$release ) {
PTDEBUG && _d('Failed to get the release, using platform');
$release = $platform;
}
chomp($release);
$release =~ s/^"|"$//g;
PTDEBUG && _d('OS version =', $release);
return $release;
}
sub get_perl_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $version = sprintf '%vd', $PERL_VERSION;
PTDEBUG && _d('Perl version', $version);
return $version;
}
sub get_perl_module_version {
my (%args) = @_;
my $item = $args{item};
return unless $item;
my $var = '$' . $item->{item} . '::VERSION';
my $version = eval "use $item->{item}; $var;";
PTDEBUG && _d('Perl version for', $var, '=', $version);
return $version;
}
sub get_mysql_variable {
return get_from_mysql(
show => 'VARIABLES',
@_,
);
}
sub get_from_mysql {
my (%args) = @_;
my $show = $args{show};
my $item = $args{item};
my $instances = $args{instances};
return unless $show && $item;
if ( !$instances || !@$instances ) {
PTDEBUG && _d('Cannot check', $item,
'because there are no MySQL instances');
return;
}
if ($item->{item} eq 'MySQL' && $item->{type} eq 'mysql_variable') {
@{$item->{vars}} = grep { $_ eq 'version' || $_ eq 'version_comment' } @{$item->{vars}};
}
my @versions;
my %version_for;
foreach my $instance ( @$instances ) {
next unless $instance->{id}; # special system instance has id=0
my $dbh = $instance->{dbh};
local $dbh->{FetchHashKeyName} = 'NAME_lc';
my $sql = qq/SHOW $show/;
PTDEBUG && _d($sql);
my $rows = $dbh->selectall_hashref($sql, 'variable_name');
my @versions;
foreach my $var ( @{$item->{vars}} ) {
$var = lc($var);
my $version = $rows->{$var}->{value};
PTDEBUG && _d('MySQL version for', $item->{item}, '=', $version,
'on', $instance->{name});
push @versions, $version;
}
$version_for{ $instance->{id} } = join(' ', @versions);
}
return \%version_for;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End VersionCheck package
# ###########################################################################
# ###########################################################################
# Percona::XtraDB::Cluster package
# This package is a copy without comments from the original. The original
# with comments and its test file can be found in the Bazaar repository at,
# lib/Percona/XtraDB/Cluster.pm
# t/lib/Percona/XtraDB/Cluster.t
# See https://launchpad.net/percona-toolkit for more information.
# ###########################################################################
{
package Percona::XtraDB::Cluster;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use Lmo;
use Data::Dumper;
{ local $EVAL_ERROR; eval { require Cxn } };
sub get_cluster_name {
my ($self, $cxn) = @_;
my $sql = "SHOW VARIABLES LIKE 'wsrep\_cluster\_name'";
PTDEBUG && _d($cxn->name, $sql);
my (undef, $cluster_name) = $cxn->dbh->selectrow_array($sql);
return $cluster_name;
}
sub is_cluster_node {
my ($self, $cxn) = @_;
my $sql = "SHOW VARIABLES LIKE 'wsrep\_on'";
PTDEBUG && _d($cxn->name, $sql);
my $row = $cxn->dbh->selectrow_arrayref($sql);
PTDEBUG && _d(Dumper($row));
return unless $row && $row->[1] && ($row->[1] eq 'ON' || $row->[1] eq '1');
my $cluster_name = $self->get_cluster_name($cxn);
return $cluster_name;
}
sub same_node {
my ($self, $cxn1, $cxn2) = @_;
foreach my $val ('wsrep\_sst\_receive\_address', 'wsrep\_node\_name', 'wsrep\_node\_address') {
my $sql = "SHOW VARIABLES LIKE '$val'";
PTDEBUG && _d($cxn1->name, $cxn2->name, $sql);
my (undef, $val1) = $cxn1->dbh->selectrow_array($sql);
my (undef, $val2) = $cxn2->dbh->selectrow_array($sql);
return unless ($val1 || '') eq ($val2 || '');
}
return 1;
}
sub find_cluster_nodes {
my ($self, %args) = @_;
my $dbh = $args{dbh};
my $dsn = $args{dsn};
my $dp = $args{DSNParser};
my $make_cxn = $args{make_cxn};
my $sql = q{SHOW STATUS LIKE 'wsrep\_incoming\_addresses'};
PTDEBUG && _d($sql);
my (undef, $addresses) = $dbh->selectrow_array($sql);
PTDEBUG && _d("Cluster nodes found: ", $addresses);
return unless $addresses;
my @addresses = grep { !/\Aunspecified\z/i }
split /,\s*/, $addresses;
my @nodes;
foreach my $address ( @addresses ) {
my ($host, $port) = split /:/, $address;
my $spec = "h=$host"
. ($port ? ",P=$port" : "");
my $node_dsn = $dp->parse($spec, $dsn);
my $node_dbh = eval { $dp->get_dbh(
$dp->get_cxn_params($node_dsn), { AutoCommit => 1 }) };
if ( $EVAL_ERROR ) {
print STDERR "Cannot connect to ", $dp->as_string($node_dsn),
", discovered through $sql: $EVAL_ERROR\n";
if ( !$port && $dsn->{P} != 3306 ) {
$address .= ":3306";
redo;
}
next;
}
PTDEBUG && _d('Connected to', $dp->as_string($node_dsn));
$node_dbh->disconnect();
push @nodes, $make_cxn->(dsn => $node_dsn);
}
return \@nodes;
}
sub remove_duplicate_cxns {
my ($self, %args) = @_;
my @cxns = @{$args{cxns}};
my $seen_ids = $args{seen_ids} || {};
PTDEBUG && _d("Removing duplicates nodes from ", join(" ", map { $_->name } @cxns));
my @trimmed_cxns;
for my $cxn ( @cxns ) {
my $id = $cxn->get_id();
PTDEBUG && _d('Server ID for ', $cxn->name, ': ', $id);
if ( ! $seen_ids->{$id}++ ) {
push @trimmed_cxns, $cxn
}
else {
PTDEBUG && _d("Removing ", $cxn->name,
", ID ", $id, ", because we've already seen it");
}
}
return \@trimmed_cxns;
}
sub same_cluster {
my ($self, $cxn1, $cxn2) = @_;
return 0 if !$self->is_cluster_node($cxn1) || !$self->is_cluster_node($cxn2);
my $cluster1 = $self->get_cluster_name($cxn1);
my $cluster2 = $self->get_cluster_name($cxn2);
return ($cluster1 || '') eq ($cluster2 || '');
}
sub autodetect_nodes {
my ($self, %args) = @_;
my $ms = $args{MasterSlave};
my $dp = $args{DSNParser};
my $make_cxn = $args{make_cxn};
my $nodes = $args{nodes};
my $seen_ids = $args{seen_ids};
my $new_nodes = [];
return $new_nodes unless @$nodes;
for my $node ( @$nodes ) {
my $nodes_found = $self->find_cluster_nodes(
dbh => $node->dbh(),
dsn => $node->dsn(),
make_cxn => $make_cxn,
DSNParser => $dp,
);
push @$new_nodes, @$nodes_found;
}
$new_nodes = $self->remove_duplicate_cxns(
cxns => $new_nodes,
seen_ids => $seen_ids
);
my $new_slaves = [];
foreach my $node (@$new_nodes) {
my $node_slaves = $ms->get_slaves(
dbh => $node->dbh(),
dsn => $node->dsn(),
make_cxn => $make_cxn,
);
push @$new_slaves, @$node_slaves;
}
$new_slaves = $self->remove_duplicate_cxns(
cxns => $new_slaves,
seen_ids => $seen_ids
);
my @new_slave_nodes = grep { $self->is_cluster_node($_) } @$new_slaves;
my $slaves_of_slaves = $self->autodetect_nodes(
%args,
nodes => \@new_slave_nodes,
);
my @autodetected_nodes = ( @$new_nodes, @$new_slaves, @$slaves_of_slaves );
return \@autodetected_nodes;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
1;
}
# ###########################################################################
# End Percona::XtraDB::Cluster package
# ###########################################################################
# ###########################################################################
# This is a combination of modules and programs in one -- a runnable module.
# http://www.perl.com/pub/a/2006/07/13/lightning-articles.html?page=last
# Or, look it up in the Camel book on pages 642 and 643 in the 3rd edition.
#
# Check at the end of this package for the call to main() which actually runs
# the program.
# ###########################################################################
package pt_online_schema_change;
use strict;
use warnings FATAL => 'all';
use English qw(-no_match_vars);
use Percona::Toolkit;
use constant PTDEBUG => $ENV{PTDEBUG} || 0;
use List::Util qw(max);
use Time::HiRes qw(time sleep);
use Data::Dumper;
$Data::Dumper::Indent = 1;
$Data::Dumper::Sortkeys = 1;
$Data::Dumper::Quotekeys = 0;
# Import Term::Readkey if available
# Not critical so don't fail if it's not
my $term_readkey = eval {
require Term::ReadKey;
Term::ReadKey->import();
1;
};
use sigtrap 'handler', \&sig_int, 'normal-signals';
my $exit_status = 0;
my $oktorun = 1;
my $dont_interrupt_now = 0;
my @drop_trigger_sqls;
my @triggers_not_dropped;
my $pxc_version = '0';
$OUTPUT_AUTOFLUSH = 1;
sub main {
local @ARGV = @_;
# Reset global vars else tests will fail.
$exit_status = 0;
$oktorun = 1;
@drop_trigger_sqls = ();
@triggers_not_dropped = ();
$dont_interrupt_now = 0;
my %stats = (
INSERT => 0,
);
# ########################################################################
# Get configuration information.
# ########################################################################
my $q = new Quoter();
my $o = new OptionParser();
$o->get_specs();
$o->get_opts();
my $dp = $o->DSNParser();
$dp->prop('set-vars', $o->set_vars());
# The original table, i.e. the one being altered, must be specified
# on the command line via the DSN.
my ($db, $tbl);
my $dsn = shift @ARGV;
if ( !$dsn ) {
$o->save_error('A DSN must be specified');
}
else {
# Parse DSN string and convert it to a DSN data struct.
$dsn = $dp->parse($dsn, $dp->parse_options($o));
$db = $dsn->{D};
$tbl = $dsn->{t};
}
my $alter_fk_method = $o->get('alter-foreign-keys-method') || '';
if ( $alter_fk_method eq 'drop_swap' ) {
$o->set('swap-tables', 0);
$o->set('drop-old-table', 0);
}
# Explicit --chunk-size disable auto chunk sizing.
$o->set('chunk-time', 0) if $o->got('chunk-size');
foreach my $opt ( qw(max-load critical-load) ) {
next unless $o->has($opt);
my $spec = $o->get($opt);
eval {
MySQLStatusWaiter::_parse_spec($o->get($opt));
};
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
$o->save_error("Invalid --$opt: $EVAL_ERROR");
}
}
# https://bugs.launchpad.net/percona-toolkit/+bug/1010232
my $n_chunk_index_cols = $o->get('chunk-index-columns');
if ( defined $n_chunk_index_cols
&& (!$n_chunk_index_cols
|| $n_chunk_index_cols =~ m/\D/
|| $n_chunk_index_cols < 1) ) {
$o->save_error('Invalid number of --chunk-index columns: '
. $n_chunk_index_cols);
}
my $tries = eval {
validate_tries($o);
};
if ( $EVAL_ERROR ) {
$o->save_error($EVAL_ERROR);
}
if ( !$o->get('drop-triggers') ) {
$o->set('drop-old-table', 0);
}
if ( !$o->get('help') ) {
if ( @ARGV ) {
$o->save_error('Specify only one DSN on the command line');
}
if ( !$db || !$tbl ) {
$o->save_error("The DSN must specify a database (D) and a table (t)");
}
if ( $o->get('progress') ) {
eval { Progress->validate_spec($o->get('progress')) };
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
$o->save_error("--progress $EVAL_ERROR");
}
}
# See the "pod-based-option-value-validation" spec for how this may
# be automagically validated.
if ( $alter_fk_method
&& $alter_fk_method ne 'auto'
&& $alter_fk_method ne 'rebuild_constraints'
&& $alter_fk_method ne 'drop_swap'
&& $alter_fk_method ne 'none' )
{
$o->save_error("Invalid --alter-foreign-keys-method value: $alter_fk_method");
}
# Issue a strong warning if alter-foreign-keys-method = none
if ( $alter_fk_method eq 'none' && !$o->get('force') ) {
print STDERR "WARNING! Using alter-foreign-keys-method = \"none\". This will typically cause foreign key violations!\nThis method of handling foreign key constraints is only provided so that the database administrator can disable the tool’s built-in functionality if desired.\n\nContinue anyway? (y/N)";
my $response;
chomp($response = );
if ($response !~ /y|(yes)/i) {
exit 1;
}
}
if ( $alter_fk_method eq 'drop_swap' && !$o->get('drop-new-table') ) {
$o->save_error("--alter-foreign-keys-method=drop_swap does not work with --no-drop-new-table.");
}
}
eval {
MasterSlave::check_recursion_method($o->get('recursion-method'));
};
if ( $EVAL_ERROR ) {
$o->save_error("Invalid --recursion-method: $EVAL_ERROR")
}
$o->usage_or_errors();
if ( $o->get('quiet') ) {
# BARON: this will fail on Windows, where there is no /dev/null. I feel
# it's a hack, like ignoring a problem instead of fixing it somehow. We
# should take a look at the things that get printed in a "normal"
# non-quiet run, and "if !quiet" them, and then do some kind of Logger.pm
# or Messager.pm module for a future release.
close STDOUT;
open STDOUT, '>', '/dev/null'
or warn "Cannot reopen STDOUT to /dev/null: $OS_ERROR";
}
# ########################################################################
# Connect to MySQL.
# ########################################################################
my $set_on_connect = sub {
my ($dbh) = @_;
return;
};
# Do not call "new Cxn(" directly; use this sub so that set_on_connect
# is applied to every cxn.
# BARON: why not make this a subroutine instead of a subroutine variable? I
# think that can be less confusing. Also, the $set_on_connect variable can be
# inlined into this subroutine. Many of our tools have a get_dbh() subroutine
# and it might be good to just make a convention of it.
my $make_cxn = sub {
my (%args) = @_;
my $cxn = Cxn->new(
%args,
DSNParser => $dp,
OptionParser => $o,
set => $set_on_connect,
);
eval { $cxn->connect() }; # connect or die trying
if ( $EVAL_ERROR ) {
die "Cannot connect to MySQL: $EVAL_ERROR\n";
}
return $cxn;
};
my $cxn = $make_cxn->(dsn => $dsn);
my $aux_cxn = $make_cxn->(dsn => $dsn, prev_dsn => $dsn);
my $cluster = Percona::XtraDB::Cluster->new;
if ( $cluster->is_cluster_node($cxn) ) {
# Because of https://bugs.launchpad.net/codership-mysql/+bug/1040108
# ptc and pt-osc check Threads_running by default for --max-load.
# Strictly speaking, they can run on 5.5.27 as long as that bug doesn't
# manifest itself. If it does, however, then the tools will wait forever.
$pxc_version = VersionParser->new($cxn->dbh);
if ( $pxc_version < '5.5.28' ) {
die "Percona XtraDB Cluster 5.5.28 or newer is required to run "
. "this tool on a cluster, but node " . $cxn->name
. " is running version " . $pxc_version->version
. ". Please upgrade the node, or run the tool on a newer node, "
. "or contact Percona for support.\n";
}
if ( $pxc_version < '5.6' && $o->got('max-flow-ctl') ) {
die "Option '--max-flow-ctl is only available for PXC version 5.6 "
. "or higher."
}
# If wsrep_OSU_method=RSU the "DDL will be only processed locally at
# the node." So _table_new (the altered version of table) will not
# replicate to other nodes but our INSERT..SELECT operations on it
# will, thereby crashing all other nodes.
my (undef, $wsrep_osu_method) = $cxn->dbh->selectrow_array(
"SHOW VARIABLES LIKE 'wsrep\_OSU\_method'");
if ( lc($wsrep_osu_method || '') ne 'toi' ) {
die "wsrep_OSU_method=TOI is required because "
. $cxn->name . " is a cluster node. wsrep_OSU_method is "
. "currently set to " . ($wsrep_osu_method || '') . ". "
. "Set it to TOI, or contact Percona for support.\n";
}
} elsif ( $o->got('max-flow-ctl') ) {
die "Option '--max-flow-ctl' is meant to be used on PXC clusters. "
."For normal async replication use '--max-lag' and '--check-interval' "
."instead.\n"
}
# ########################################################################
# Check if MySQL is new enough to have the triggers we need.
# Although triggers were introduced in 5.0.2, "Prior to MySQL 5.0.10,
# triggers cannot contain direct references to tables by name."
# ########################################################################
my $server_version = VersionParser->new($cxn->dbh());
if ( $server_version < '5.0.10' ) {
die "This tool requires MySQL 5.0.10 or newer.\n";
}
# Use LOCK IN SHARE mode unless MySQL 5.0 because there's a bug like
# http://bugs.mysql.com/bug.php?id=45694
my $lock_in_share_mode = $server_version < '5.1' ? 0 : 1;
# ########################################################################
# Check if analyze-before-swap is necessary.
# https://bugs.launchpad.net/percona-toolkit/+bug/1491261
# ########################################################################
my $analyze_table = $o->get('analyze-before-swap');
if ( $o->got('analyze-before-swap') ) {
# User specified so respect their wish. If --analyze-before-swap, do it
# regardless of MySQL version and innodb_stats_peristent.
# If --no-analyze-before-swap, don't do it.
PTDEBUG && _d('User specified explicit --analyze-before-swap:',
($analyze_table ? 'on' : 'off'));
}
elsif ( $analyze_table ) {
# User did not specify --analyze-before-swap on command line, and it
# defaults to "yes", so auto-check for the conditions it's affected by
# and enable only if those conditions are true.
if ( $server_version >= '5.6' ) {
my (undef, $innodb_stats_persistent) = $cxn->dbh->selectrow_array(
"SHOW VARIABLES LIKE 'innodb_stats_persistent'");
if ($innodb_stats_persistent eq 'ON' || $innodb_stats_persistent eq '1') {
PTDEBUG && _d('innodb_stats_peristent is ON, enabling --analyze-before-swap');
$analyze_table = 1;
} else {
PTDEBUG && _d('innodb_stats_peristent is OFF, disabling --analyze-before-swap');
$analyze_table = 0;
}
} else {
PTDEBUG && _d('MySQL < 5.6, disabling --analyze-before-swap');
$analyze_table = 0;
}
}
# ########################################################################
# Create --plugin.
# ########################################################################
my $plugin;
if ( my $file = $o->get('plugin') ) {
die "--plugin file $file does not exist\n" unless -f $file;
eval {
require $file;
};
die "Error loading --plugin $file: $EVAL_ERROR" if $EVAL_ERROR;
eval {
$plugin = pt_online_schema_change_plugin->new(
cxn => $cxn,
aux_cxn => $aux_cxn,
alter => $o->get('alter'),
execute => $o->get('execute'),
dry_run => $o->get('dry-run'),
print => $o->get('print'),
quiet => $o->get('quiet'),
Quoter => $q,
);
};
die "Error creating --plugin: $EVAL_ERROR" if $EVAL_ERROR;
print "Created plugin from $file.\n";
}
# ########################################################################
# Setup lag and load monitors.
# ########################################################################
my $slaves; # all slaves that are found or specified
my $slave_lag_cxns; # slaves whose lag we'll check
my $replica_lag; # ReplicaLagWaiter object
my $replica_lag_pr; # Progress for ReplicaLagWaiter
my $flow_ctl; # FlowControlWaiter object
my $flow_ctl_pr; # Progress for FlowControlWaiter
my $sys_load; # MySQLStatusWaiter object
my $sys_load_pr; # Progress for MySQLStatusWaiter object
if ( $o->get('execute') ) {
# #####################################################################
# Find and connect to slaves.
# #####################################################################
my $ms = new MasterSlave(
OptionParser => $o,
DSNParser => $dp,
Quoter => $q,
);
$slaves = $ms->get_slaves(
dbh => $cxn->dbh(),
dsn => $cxn->dsn(),
make_cxn => sub {
return $make_cxn->(@_, prev_dsn => $cxn->dsn());
},
);
PTDEBUG && _d(scalar @$slaves, 'slaves found');
if ( scalar @$slaves ) {
print "Found " . scalar(@$slaves) . " slaves:\n";
foreach my $cxn ( @$slaves ) {
print " " . $cxn->name() . "\n";
}
}
elsif ( ($o->get('recursion-method') || '') ne 'none') {
print "No slaves found. See --recursion-method if host "
. $cxn->name() . " has slaves.\n";
}
else {
print "Ignoring all slaves because --recursion-method=none "
. "was specified\n";
}
if ( my $dsn = $o->get('check-slave-lag') ) {
PTDEBUG && _d('Will use --check-slave-lag to check for slave lag');
my $cxn = $make_cxn->(
dsn_string => $o->get('check-slave-lag'),
prev_dsn => $cxn->dsn(),
);
$slave_lag_cxns = [ $cxn ];
}
else {
PTDEBUG && _d('Will check slave lag on all slaves');
$slave_lag_cxns = $slaves;
}
if ( $slave_lag_cxns && scalar @$slave_lag_cxns ) {
print "Will check slave lag on:\n";
foreach my $cxn ( @$slave_lag_cxns ) {
print " " . $cxn->name() . "\n";
}
}
else {
print "Not checking slave lag because no slaves were found "
. "and --check-slave-lag was not specified.\n";
}
# #####################################################################
# Check for replication filters.
# #####################################################################
if ( $o->get('check-replication-filters') ) {
PTDEBUG && _d("Checking slave replication filters");
my @all_repl_filters;
foreach my $slave ( @$slaves ) {
my $repl_filters = $ms->get_replication_filters(
dbh => $slave->dbh(),
);
if ( keys %$repl_filters ) {
push @all_repl_filters,
{ name => $slave->name(),
filters => $repl_filters,
};
}
}
if ( @all_repl_filters ) {
my $msg = "Replication filters are set on these hosts:\n";
foreach my $host ( @all_repl_filters ) {
my $filters = $host->{filters};
$msg .= " $host->{name}\n"
. join("\n", map { " $_ = $host->{filters}->{$_}" }
keys %{$host->{filters}})
. "\n";
}
$msg .= "Please read the --check-replication-filters documentation "
. "to learn how to solve this problem.";
die $msg;
}
}
# #####################################################################
# Make a ReplicaLagWaiter to help wait for slaves after each chunk.
# Note: the "sleep" function is also used by MySQLStatusWaiter and
# FlowControlWaiter
# #####################################################################
my $sleep = sub {
# Don't let the master dbh die while waiting for slaves because we
# may wait a very long time for slaves.
my $dbh = $cxn->dbh();
if ( !$dbh || !$dbh->ping() ) {
eval { $dbh = $cxn->connect() }; # connect or die trying
if ( $EVAL_ERROR ) {
$oktorun = 0; # flag for cleanup tasks
chomp $EVAL_ERROR;
die "Lost connection to " . $cxn->name() . " while waiting for "
. "replica lag ($EVAL_ERROR)\n";
}
}
$dbh->do("SELECT 'pt-online-schema-change keepalive'");
sleep $o->get('check-interval');
return;
};
my $get_lag;
# The plugin is able to override the slavelag check so tools like
# pt-heartbeat or other replicators (Tungsten...) can be used to
# measure replication lag
if ( $plugin && $plugin->can('get_slave_lag') ) {
$get_lag = $plugin->get_slave_lag(oktorun => \$oktorun);
}
else {
$get_lag = sub {
my ($cxn) = @_;
my $dbh = $cxn->dbh();
if ( !$dbh || !$dbh->ping() ) {
eval { $dbh = $cxn->connect() }; # connect or die trying
if ( $EVAL_ERROR ) {
# As the docs say: "The tool waits forever for replicas
# to stop lagging. If any replica is stopped, the tool
# waits forever until the replica is started."
# https://bugs.launchpad.net/percona-toolkit/+bug/1402051
PTDEBUG && _d('Cannot connect to', $cxn->name(), ':',
$EVAL_ERROR);
# Make ReplicaLagWaiter::wait() report slave is stopped.
return undef;
}
}
my $lag;
eval {
$lag = $ms->get_slave_lag($dbh);
};
if ( $EVAL_ERROR ) {
PTDEBUG && _d('Cannot get lag for', $cxn->name(), ':',
$EVAL_ERROR);
}
return $lag; # undef if error
};
}
$replica_lag = new ReplicaLagWaiter(
slaves => $slave_lag_cxns,
max_lag => $o->get('max-lag'),
oktorun => sub { return $oktorun },
get_lag => $get_lag,
sleep => $sleep,
);
my $get_status;
{
my $sql = "SHOW GLOBAL STATUS LIKE ?";
my $sth = $cxn->dbh()->prepare($sql);
$get_status = sub {
my ($var) = @_;
PTDEBUG && _d($sth->{Statement}, $var);
$sth->execute($var);
my (undef, $val) = $sth->fetchrow_array();
return $val;
};
}
eval {
$sys_load = new MySQLStatusWaiter(
max_spec => $o->get('max-load'),
critical_spec => $o->get('critical-load'),
get_status => $get_status,
oktorun => sub { return $oktorun },
sleep => $sleep,
);
};
if ( $EVAL_ERROR ) {
chomp $EVAL_ERROR;
die "Error checking --max-load or --critial-load: $EVAL_ERROR. "
. "Check that the variables specified for --max-load and "
. "--critical-load are spelled correctly and exist in "
. "SHOW GLOBAL STATUS. Current values for these options are:\n"
. " --max-load " . (join(',', @{$o->get('max-load')})) . "\n"
. " --critial-load " . (join(',', @{$o->get('critical-load')}))
. "\n";
}
if ( $pxc_version >= '5.6' && $o->got('max-flow-ctl') ) {
$flow_ctl = new FlowControlWaiter(
node => $cxn->dbh(),
max_flow_ctl => $o->get('max-flow-ctl'),
oktorun => sub { return $oktorun },
sleep => $sleep,
);
}
if ( $o->get('progress') ) {
$replica_lag_pr = new Progress(
jobsize => scalar @$slaves,
spec => $o->get('progress'),
name => "Waiting for replicas to catch up", # not used
);
$sys_load_pr = new Progress(
jobsize => scalar @{$o->get('max-load')},
spec => $o->get('progress'),
name => "Waiting for --max-load", # not used
);
if ( $pxc_version >= '5.6' && $o->got('max-flow-ctl') ) {
$flow_ctl_pr = new Progress(
jobsize => $o->get('max-flow-ctl'),
spec => $o->get('progress'),
name => "Waiting for flow control to abate", # not used
);
}
}
}
# ########################################################################
# Do the version-check
# ########################################################################
if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) {
VersionCheck::version_check(
force => $o->got('version-check'),
instances => [
map (
{ +{ dbh => $_->dbh(), dsn => $_->dsn() } }
$cxn, ($slaves ? @$slaves : ())
)
],
);
}
# ########################################################################
# Setup and check the original table.
# ########################################################################
my $tp = TableParser->new(Quoter => $q);
# Common table data struct (that modules like NibbleIterator expect).
my $orig_tbl = {
db => $db,
tbl => $tbl,
name => $q->quote($db, $tbl),
};
check_orig_table(
orig_tbl => $orig_tbl,
Cxn => $cxn,
OptionParser => $o,
TableParser => $tp,
Quoter => $q,
);
# ########################################################################
# Print --tries.
# ########################################################################
print "Operation, tries, wait:\n";
{
my $fmt = " %s, %s, %s\n";
foreach my $op ( sort keys %$tries ) {
printf $fmt, $op, $tries->{$op}->{tries}, $tries->{$op}->{wait};
}
}
# ########################################################################
# Get child tables of the original table, if necessary.
# ########################################################################
my $child_tables;
if ( ($alter_fk_method || '') eq 'none' ) {
print "Not updating foreign keys because "
. "--alter-foreign-keys-method=none. Foreign keys "
. "that reference the table will no longer work.\n";
}
else {
$child_tables = find_child_tables(
tbl => $orig_tbl,
Cxn => $cxn,
Quoter => $q,
);
if ( !$child_tables ) {
if ( $alter_fk_method ) {
warn "No foreign keys reference $orig_tbl->{name}; ignoring "
. "--alter-foreign-keys-method.\n";
if ( $alter_fk_method eq 'drop_swap' ) {
# These opts are disabled at the start if the user specifies
# the drop_swap method, but now that we know there are no
# child tables, we must re-enable these to make the alter work.
$o->set('swap-tables', 1);
$o->set('drop-old-table', 1);
}
$alter_fk_method = '';
}
# No child tables and --alter-fk-method wasn't specified,
# so nothing to do.
}
else {
print "Child tables:\n";
foreach my $child_table ( @$child_tables ) {
printf " %s (approx. %s rows)\n",
$child_table->{name},
$child_table->{row_est} || '?';
}
if ( $alter_fk_method ) {
# Let the user know how we're going to update the child table
# fk refs.
my $choice
= $alter_fk_method eq 'none' ? "not"
: $alter_fk_method eq 'auto' ? "automatically choose the method to"
: "use the $alter_fk_method method to";
print "Will $choice update foreign keys.\n";
}
else {
print "You did not specify --alter-foreign-keys-method, but there "
. "are foreign keys that reference the table. "
. "Please read the tool's documentation carefully.\n";
return 1;
}
}
}
# ########################################################################
# XXX
# Ready to begin the alter! Nothing has been changed on the server at
# this point; we've just checked and looked for things. Past this point,
# the code is live if --execute, else it's doing a --dry-run. Or, if
# the user didn't read the docs, we may bail out here.
# XXX
# ########################################################################
if ( $o->get('dry-run') ) {
print "Starting a dry run. $orig_tbl->{name} will not be altered. "
. "Specify --execute instead of --dry-run to alter the table.\n";
}
elsif ( $o->get('execute') ) {
print "Altering $orig_tbl->{name}...\n";
}
else {
print "Exiting without altering $orig_tbl->{name} because neither "
. "--dry-run nor --execute was specified. Please read the tool's "
. "documentation carefully before using this tool.\n";
return 1;
}
# ########################################################################
# Create a cleanup task object to undo changes (i.e. clean up) if the
# code dies, or we may call this explicitly at the end if all goes well.
# ########################################################################
my @cleanup_tasks;
my $cleanup = new CleanupTask(
sub {
# XXX We shouldn't copy $EVAL_ERROR here, but I found that
# errors are not re-thrown in tests. If you comment (*) out this
# line and the die below, an error fails:
# not ok 5 - Doesn't try forever to find a new table name
# Failed test 'Doesn't try forever to find a new table name'
# at /Users/daniel/p/pt-osc-2.1.1/lib/PerconaTest.pm line 559.
# ''
# doesn't match '(?-xism:Failed to find a unique new table name)'
# (*) Frank: commented them out because it caused infinite loop
# and the mentioned test error doesn't arise
#my $original_error = $EVAL_ERROR;
foreach my $task ( reverse @cleanup_tasks ) {
eval {
$task->();
};
if ( $EVAL_ERROR ) {
warn "Error cleaning up: $EVAL_ERROR\n";
}
}
#die $original_error if $original_error; # rethrow original error
return;
}
);
local $SIG{__DIE__} = sub {
return if $EXCEPTIONS_BEING_CAUGHT;
local $EVAL_ERROR = $_[0];
undef $cleanup;
die @_;
};
# The last cleanup task is to report whether or not the orig table
# was altered.
push @cleanup_tasks, sub {
PTDEBUG && _d('Clean up done, report if orig table was altered');
if ( $o->get('dry-run') ) {
print "Dry run complete. $orig_tbl->{name} was not altered.\n";
}
else {
if ( $orig_tbl->{swapped} ) {
if ( $orig_tbl->{success} ) {
print "Successfully altered $orig_tbl->{name}.\n";
}
else {
print "Altered $orig_tbl->{name} but there were errors "
. "or warnings.\n";
}
}
else {
print "$orig_tbl->{name} was not altered.\n";
}
}
return;
};
# The 2nd to last cleanup task is printing the --statistics which
# may reveal something about the failure.
if ( $o->get('statistics') ) {
push @cleanup_tasks, sub {
my $n = max( map { length $_ } keys %stats );
my $fmt = "# %-${n}s %5s\n";
printf $fmt, 'Event', 'Count';
printf $fmt, ('=' x $n),'=====';
foreach my $event ( sort keys %stats ) {
printf $fmt,
$event, (defined $stats{$event} ? $stats{$event} : '?');
}
};
}
# ########################################################################
# Check the --alter statement.
# ########################################################################
my $renamed_cols = {};
if ( my $alter = $o->get('alter') ) {
$renamed_cols = find_renamed_cols(
alter => $o->get('alter'),
TableParser => $tp,
);
if ( $o->get('check-alter') ) {
check_alter(
tbl => $orig_tbl,
alter => $alter,
dry_run => $o->get('dry-run'),
renamed_cols => $renamed_cols,
Cxn => $cxn,
TableParser => $tp,
);
}
}
if ( %$renamed_cols && !$o->get('dry-run') ) {
print "Renaming columns:\n"
. join("\n", map { " $_ to $renamed_cols->{$_}" }
sort keys %$renamed_cols)
. "\n";
}
# ########################################################################
# Check and create PID file if user specified --pid.
# ########################################################################
my $daemon = Daemon->new(
daemonize => 0, # not daemoninzing, just PID file
pid_file => $o->get('pid'),
);
$daemon->run();
# ########################################################################
# Init the --plugin.
# ########################################################################
# --plugin hook
if ( $plugin && $plugin->can('init') ) {
$plugin->init(
orig_tbl => $orig_tbl,
child_tables => $child_tables,
renamed_cols => $renamed_cols,
slaves => $slaves,
slave_lag_cxns => $slave_lag_cxns,
);
}
# #####################################################################
# Step 1: Create the new table.
# #####################################################################
my $new_table_name = $o->get('new-table-name');
my $new_table_prefix = $o->got('new-table-name') ? undef : '_';
# --plugin hook
if ( $plugin && $plugin->can('before_create_new_table') ) {
$plugin->before_create_new_table(
new_table_name => $new_table_name,
new_table_prefix => $new_table_prefix,
);
}
my $new_tbl;
eval {
$new_tbl = create_new_table(
new_table_name => $new_table_name,
new_table_prefix => $new_table_prefix,
orig_tbl => $orig_tbl,
Cxn => $cxn,
Quoter => $q,
OptionParser => $o,
TableParser => $tp,
);
};
if ( $EVAL_ERROR ) {
die "Error creating new table: $EVAL_ERROR\n";
}
# If the new table still exists, drop it unless the tool was interrupted.
push @cleanup_tasks, sub {
PTDEBUG && _d('Clean up new table');
my $new_tbl_exists = $tp->check_table(
dbh => $cxn->dbh(),
db => $new_tbl->{db},
tbl => $new_tbl->{tbl},
);
PTDEBUG && _d('New table exists:', $new_tbl_exists ? 'yes' : 'no');
return unless $new_tbl_exists;
my $sql = "DROP TABLE IF EXISTS $new_tbl->{name};";
if ( !$oktorun ) {
# The tool was interrupted, so do not drop the new table
# in case the user wants to resume (once resume capability
# is implemented).
print "Not dropping the new table $new_tbl->{name} because "
. "the tool was interrupted. To drop the new table, "
. "execute:\n$sql\n";
}
elsif ( $orig_tbl->{copied} && !$orig_tbl->{swapped} ) {
print "Not dropping the new table $new_tbl->{name} because "
. "--swap-tables failed. To drop the new table, "
. "execute:\n$sql\n";
}
elsif ( !$o->get('drop-new-table') ) {
# https://bugs.launchpad.net/percona-toolkit/+bug/998831
print "Not dropping the new table $new_tbl->{name} because "
. "--no-drop-new-table was specified. To drop the new table, "
. "execute:\n$sql\n";
}
elsif ( @triggers_not_dropped ) {
# https://bugs.launchpad.net/percona-toolkit/+bug/1188002
print "Not dropping the new table $new_tbl->{name} because "
. "dropping these triggers failed:\n"
. join("\n", map { " $_" } @triggers_not_dropped)
. "\nThese triggers must be dropped before dropping "
. "$new_tbl->{name}, else writing to $orig_tbl->{name} will "
. "cause MySQL error 1146 (42S02): \"Table $new_tbl->{name} "
. " doesn't exist\".\n";
}
else {
print ts("Dropping new table...\n");
print $sql, "\n" if $o->get('print');
PTDEBUG && _d($sql);
eval {
$cxn->dbh()->do($sql);
};
if ( $EVAL_ERROR ) {
warn ts("Error dropping new table $new_tbl->{name}: $EVAL_ERROR\n"
. "To try dropping the new table again, execute:\n$sql\n");
}
print ts("Dropped new table OK.\n");
}
};
if ( $slaves && scalar @$slaves ) {
foreach my $slave (@$slaves) {
my ($pr, $pr_first_report);
if ( $o->get('progress') ) {
$pr = new Progress(
jobsize => scalar @$slaves,
spec => $o->get('progress'),
name => "Waiting for " . $slave->name(),
);
$pr_first_report = sub {
print "Waiting forever for new table $new_tbl->{name} to replicate "
. "to " . $slave->name() . "...\n";
};
}
$pr->start() if $pr;
my $has_table = 0;
while ( !$has_table ) {
$has_table = $tp->check_table(
dbh => $slave->dbh(),
db => $new_tbl->{db},
tbl => $new_tbl->{tbl}
);
last if $has_table;
$pr->update(
sub { return 0; },
first_report => $pr_first_report,
) if $pr;
sleep 1;
}
}
}
# --plugin hook
if ( $plugin && $plugin->can('after_create_new_table') ) {
$plugin->after_create_new_table(
new_tbl => $new_tbl,
);
}
# #####################################################################
# Step 2: Alter the new, empty table. This should be very quick,
# or die if the user specified a bad alter statement.
# #####################################################################
# --plugin hook
if ( $plugin && $plugin->can('before_alter_new_table') ) {
$plugin->before_alter_new_table(
new_tbl => $new_tbl,
);
}
if ( my $alter = $o->get('alter') ) {
print "Altering new table...\n";
my $sql = "ALTER TABLE $new_tbl->{name} $alter";
print $sql, "\n" if $o->get('print');
PTDEBUG && _d($sql);
eval {
$cxn->dbh()->do($sql);
};
if ( $EVAL_ERROR ) {
die "Error altering new table $new_tbl->{name}: $EVAL_ERROR\n"
}
print "Altered $new_tbl->{name} OK.\n";
}
# Get the new table struct. This shouldn't die because
# we just created the table successfully so we know it's
# there. But the ghost of Ryan is everywhere.
my $ddl = $tp->get_create_table(
$cxn->dbh(),
$new_tbl->{db},
$new_tbl->{tbl},
);
$new_tbl->{tbl_struct} = $tp->parse($ddl);
# Determine what columns the original and new table share.
# If the user drops a col, that's easy: just don't copy it. If they
# add a column, it must have a default value. Other alterations
# may or may not affect the copy process--we'll know when we try!
# Col posn (position) is just for looks because user's like
# to see columns listed in their original order, not Perl's
# random hash key sorting.
my $col_posn = $orig_tbl->{tbl_struct}->{col_posn};
my $orig_cols = $orig_tbl->{tbl_struct}->{is_col};
my $new_cols = $new_tbl->{tbl_struct}->{is_col};
my @common_cols = map { +{ old => $_, new => $renamed_cols->{$_} || $_ } }
sort { $col_posn->{$a} <=> $col_posn->{$b} }
grep { $new_cols->{$_} || $renamed_cols->{$_} }
keys %$orig_cols;
PTDEBUG && _d('Common columns', Dumper(\@common_cols));
# Find a pk or unique index to use for the delete trigger. can_nibble()
# above returns an index, but NibbleIterator will use non-unique indexes,
# so we have to do this again here.
{
my $indexes = $new_tbl->{tbl_struct}->{keys}; # brevity
foreach my $index ( $tp->sort_indexes($new_tbl->{tbl_struct}) ) {
if ( $index eq 'PRIMARY' || $indexes->{$index}->{is_unique} ) {
PTDEBUG && _d('Delete trigger new index:', Dumper($index));
$new_tbl->{del_index} = $index;
last;
}
}
PTDEBUG && _d('New table delete index:', $new_tbl->{del_index});
}
{
my $indexes = $orig_tbl->{tbl_struct}->{keys}; # brevity
foreach my $index ( $tp->sort_indexes($orig_tbl->{tbl_struct}) ) {
if ( $index eq 'PRIMARY' || $indexes->{$index}->{is_unique} ) {
PTDEBUG && _d('Delete trigger orig index:', Dumper($index));
$orig_tbl->{del_index} = $index;
last;
}
}
PTDEBUG && _d('Orig table delete index:', $orig_tbl->{del_index});
}
if ( !$new_tbl->{del_index} ) {
die "The new table $new_tbl->{name} does not have a PRIMARY KEY "
. "or a unique index which is required for the DELETE trigger.\n";
}
# Determine whether to use the new or orig table delete index.
# The new table del index is preferred due to
# https://bugs.launchpad.net/percona-toolkit/+bug/1062324
# In short, if the chosen del index is re-created with new columns,
# its original columns may be dropped, so just use its new columns.
# But, due to https://bugs.launchpad.net/percona-toolkit/+bug/1103672,
# the chosen del index on the new table may reference columns which
# do not/no longer exist in the orig table, so we check for this
# and, if it's the case, we fall back to using the del index from
# the orig table.
my $del_tbl = $new_tbl; # preferred
my $new_del_index_cols # brevity
= $new_tbl->{tbl_struct}->{keys}->{ $new_tbl->{del_index} }->{cols};
foreach my $new_del_index_col ( @$new_del_index_cols ) {
if ( !exists $orig_cols->{$new_del_index_col} ) {
if ( !$orig_tbl->{del_index} ) {
die "The new table index $new_tbl->{del_index} would be used "
. "for the DELETE trigger, but it uses column "
. "$new_del_index_col which does not exist in the original "
. "table and the original table does not have a PRIMARY KEY "
. "or a unique index to use for the DELETE trigger.\n";
}
print "Using original table index $orig_tbl->{del_index} for the "
. "DELETE trigger instead of new table index $new_tbl->{del_index} "
. "because the new table index uses column $new_del_index_col "
. "which does not exist in the original table.\n";
$del_tbl = $orig_tbl;
last;
}
}
{
my $del_cols
= $del_tbl->{tbl_struct}->{keys}->{ $del_tbl->{del_index} }->{cols};
PTDEBUG && _d('Index for delete trigger: table', $del_tbl->{name},
'index', $del_tbl->{del_index},
'columns', @$del_cols);
}
# --plugin hook
if ( $plugin && $plugin->can('after_alter_new_table') ) {
$plugin->after_alter_new_table(
new_tbl => $new_tbl,
del_tbl => $del_tbl,
);
}
# ########################################################################
# Step 3: Create the triggers to capture changes on the original table and
# apply them to the new table.
# ########################################################################
my $retry = new Retry();
# Drop the triggers. We can save this cleanup task before
# adding the triggers because if adding them fails, this will be
# called which will drop whichever triggers were created.
my $drop_triggers = $o->get('drop-triggers');
push @cleanup_tasks, sub {
PTDEBUG && _d('Clean up triggers');
# --plugin hook
if ( $plugin && $plugin->can('before_drop_triggers') ) {
$plugin->before_drop_triggers(
oktorun => $oktorun,
drop_triggers => $drop_triggers,
drop_trigger_sqls => \@drop_trigger_sqls,
);
}
if ( !$oktorun ) {
print "Not dropping triggers because the tool was interrupted. "
. "To drop the triggers, execute:\n"
. join("\n", @drop_trigger_sqls) . "\n";
}
elsif ( !$drop_triggers ) {
print "Not dropping triggers because --no-drop-triggers was "
. "specified. To drop the triggers, execute:\n"
. join("\n", @drop_trigger_sqls) . "\n";
}
else {
drop_triggers(
tbl => $orig_tbl,
Cxn => $cxn,
Quoter => $q,
OptionParser => $o,
Retry => $retry,
tries => $tries,
stats => \%stats,
);
}
};
# --plugin hook
if ( $plugin && $plugin->can('before_create_triggers') ) {
$plugin->before_create_triggers();
}
my @trigger_names = eval {
create_triggers(
orig_tbl => $orig_tbl,
new_tbl => $new_tbl,
del_tbl => $del_tbl,
columns => \@common_cols,
Cxn => $cxn,
Quoter => $q,
OptionParser => $o,
Retry => $retry,
tries => $tries,
stats => \%stats,
);
};
if ( $EVAL_ERROR ) {
die "Error creating triggers: $EVAL_ERROR\n";
};
# --plugin hook
if ( $plugin && $plugin->can('after_create_triggers') ) {
$plugin->after_create_triggers();
}
# #####################################################################
# Step 4: Copy rows.
# #####################################################################
# The hashref of callbacks below is what NibbleIterator calls internally
# to do all the copy work. The callbacks do not need to eval their work
# because the higher call to $nibble_iter->next() is eval'ed which will
# catch any errors in the callbacks.
my $total_rows = 0;
my $total_time = 0;
my $avg_rate = 0; # rows/second
my $limit = $o->get('chunk-size-limit'); # brevity
my $chunk_time = $o->get('chunk-time'); # brevity
my $callbacks = {
init => sub {
my (%args) = @_;
my $tbl = $args{tbl};
my $nibble_iter = $args{NibbleIterator};
my $statements = $nibble_iter->statements();
my $boundary = $nibble_iter->boundaries();
if ( $o->get('dry-run') ) {
print "Not copying rows because this is a dry run.\n";
}
else {
if ( !$nibble_iter->one_nibble() && !$boundary->{first_lower} ) {
# https://bugs.launchpad.net/percona-toolkit/+bug/1020997
print "$tbl->{name} is empty, no rows to copy.\n";
return;
}
else {
print ts("Copying approximately "
. $nibble_iter->row_estimate() . " rows...\n");
}
}
if ( $o->get('print') ) {
# Print the checksum and next boundary statements.
foreach my $sth ( sort keys %$statements ) {
next if $sth =~ m/^explain/;
if ( $statements->{$sth} ) {
print $statements->{$sth}->{Statement}, "\n";
}
}
}
return unless $o->get('execute');
# If table is a single chunk on the master, make sure it's also
# a single chunk on all slaves. E.g. if a slave is out of sync
# and has a lot more rows than the master, single chunking on the
# master could cause the slave to choke.
if ( $nibble_iter->one_nibble() ) {
PTDEBUG && _d('Getting table row estimate on replicas');
my @too_large;
foreach my $slave ( @$slaves ) {
my ($n_rows) = NibbleIterator::get_row_estimate(
Cxn => $slave,
tbl => $tbl,
);
PTDEBUG && _d('Table on',$slave->name(),'has', $n_rows, 'rows');
if ( $limit && $n_rows && $n_rows > ($tbl->{chunk_size} * $limit) ) {
PTDEBUG && _d('Table too large on', $slave->name());
push @too_large, [$slave->name(), $n_rows || 0];
}
}
if ( @too_large ) {
my $msg
= "Cannot copy table $tbl->{name} because"
. " on the master it would be checksummed in one chunk"
. " but on these replicas it has too many rows:\n";
foreach my $info ( @too_large ) {
$msg .= " $info->[1] rows on $info->[0]\n";
}
$msg .= "The current chunk size limit is "
. ($tbl->{chunk_size} * $limit)
. " rows (chunk size=$tbl->{chunk_size}"
. " * chunk size limit=$limit).\n";
die ts($msg);
}
}
else { # chunking the table
if ( $o->get('check-plan') ) {
my $idx_len = new IndexLength(Quoter => $q);
my ($key_len, $key) = $idx_len->index_length(
Cxn => $args{Cxn},
tbl => $tbl,
index => $nibble_iter->nibble_index(),
n_index_cols => $o->get('chunk-index-columns'),
);
if ( !$key || lc($key) ne lc($nibble_iter->nibble_index()) ) {
die ts("Cannot determine the key_len of the chunk index "
. "because MySQL chose "
. ($key ? "the $key" : "no") . " index "
. "instead of the " . $nibble_iter->nibble_index()
. " index for the first lower boundary statement. "
. "See --[no]check-plan in the documentation for more "
. "information.");
}
elsif ( !$key_len ) {
die ts("The key_len of the $key index is "
. (defined $key_len ? "zero" : "NULL")
. ", but this should not be possible. "
. "See --[no]check-plan in the documentation for more "
. "information.");
}
$tbl->{key_len} = $key_len;
}
}
return 1; # continue nibbling table
},
next_boundaries => sub {
my (%args) = @_;
my $tbl = $args{tbl};
my $nibble_iter = $args{NibbleIterator};
my $sth = $nibble_iter->statements();
my $boundary = $nibble_iter->boundaries();
return 0 if $o->get('dry-run');
return 1 if $nibble_iter->one_nibble();
# Check that MySQL will use the nibble index for the next upper
# boundary sql. This check applies to the next nibble. So if
# the current nibble number is 5, then nibble 5 is already done
# and we're checking nibble number 6.
# Skip if --nocheck-plan See: https://bugs.launchpad.net/percona-toolkit/+bug/1340728
if ( $o->get('check-plan') ) {
my $expl = explain_statement(
tbl => $tbl,
sth => $sth->{explain_upper_boundary},
vals => [ @{$boundary->{lower}}, $nibble_iter->limit() ],
);
if ( lc($expl->{key} || '') ne lc($nibble_iter->nibble_index() || '') ) {
my $msg
= "Aborting copying table $tbl->{name} at chunk "
. ($nibble_iter->nibble_number() + 1)
. " because it is not safe to ascend. Chunking should "
. "use the "
. ($nibble_iter->nibble_index() || '?')
. " index, but MySQL EXPLAIN reports that "
. ($expl->{key} ? "the $expl->{key}" : "no")
. " index will be used for "
. $sth->{upper_boundary}->{Statement}
. " with values "
. join(", ", map { defined $_ ? $_ : "NULL" }
(@{$boundary->{lower}}, $nibble_iter->limit()))
. "\n";
die ts($msg);
}
}
# Once nibbling begins for a table, control does not return to this
# tool until nibbling is done because, as noted above, all work is
# done in these callbacks. This callback is the only place where we
# can prematurely stop nibbling by returning false. This allows
# Ctrl-C to stop the tool between nibbles instead of between tables.
return $oktorun; # continue nibbling table?
},
exec_nibble => sub {
my (%args) = @_;
my $tbl = $args{tbl};
my $nibble_iter = $args{NibbleIterator};
return if $o->get('dry-run');
# Count every chunk, even if it's ultimately skipped, etc.
$tbl->{results}->{n_chunks}++;
# Die unless the nibble is safe.
nibble_is_safe(
%args,
OptionParser => $o,
);
# Exec and time the chunk checksum query.
$tbl->{nibble_time} = exec_nibble(
%args,
tries => $tries,
Retry => $retry,
Quoter => $q,
stats => \%stats,
);
PTDEBUG && _d('Nibble time:', $tbl->{nibble_time});
# We're executing REPLACE queries which don't return rows.
# Returning 0 from this callback causes the nibble iter to
# get the next boundaries/nibble.
return 0;
},
after_nibble => sub {
my (%args) = @_;
my $tbl = $args{tbl};
my $nibble_iter = $args{NibbleIterator};
return unless $o->get('execute');
# Update rate, chunk size, and progress if the nibble actually
# selected some rows.
my $cnt = $tbl->{row_cnt};
if ( ($cnt || 0) > 0 ) {
# Update the rate of rows per second for the entire server.
# This is used for the initial chunk size of the next table.
$total_rows += $cnt;
$total_time += $tbl->{nibble_time};
$avg_rate = int($total_rows / $total_time);
PTDEBUG && _d('Average copy rate (rows/s):', $avg_rate);
# Adjust chunk size. This affects the next chunk.
if ( $chunk_time ) {
# Calcuate a new chunk-size based on the rate of rows/s.
$tbl->{chunk_size} = $tbl->{rate}->update(
$cnt, # processed this many rows
$tbl->{nibble_time}, # is this amount of time
);
if ( $tbl->{chunk_size} < 1 ) {
# This shouldn't happen. WeightedAvgRate::update() may
# return a value < 1, but minimum chunk size is 1.
$tbl->{chunk_size} = 1;
# This warning is printed once per table.
if ( !$tbl->{warned_slow} ) {
warn ts("Rows are copying very slowly. "
. "--chunk-size has been automatically reduced to 1. "
. "Check that the server is not being overloaded, "
. "or increase --chunk-time. The last chunk "
. "selected $cnt rows and took "
. sprintf('%.3f', $tbl->{nibble_time})
. " seconds to execute.\n");
$tbl->{warned_slow} = 1;
}
}
# Update chunk-size based on the rate of rows/s.
$nibble_iter->set_chunk_size($tbl->{chunk_size});
}
# Every table should have a Progress obj; update it.
if ( my $tbl_pr = $tbl->{progress} ) {
$tbl_pr->update( sub { return $total_rows } );
}
}
# Wait forever for slaves to catch up.
$replica_lag_pr->start() if $replica_lag_pr;
$replica_lag->wait(Progress => $replica_lag_pr);
# Wait forever for system load to abate. wait() will die if
# --critical load is reached.
$sys_load_pr->start() if $sys_load_pr;
$sys_load->wait(Progress => $sys_load_pr);
# Wait forever for flow control to abate.
$flow_ctl_pr->start() if $flow_ctl_pr;
$flow_ctl->wait(Progress => $flow_ctl_pr) if $flow_ctl;
# sleep between chunks to avoid overloading PXC nodes
my $sleep = $args{NibbleIterator}->{OptionParser}->get('sleep');
if ( $sleep ) {
sleep $sleep;
}
return;
},
done => sub {
if ( $o->get('execute') ) {
print ts("Copied rows OK.\n");
}
},
};
# NibbleIterator combines these two statements and adds
# "FROM $orig_table->{name} WHERE ".
my $dml = "INSERT LOW_PRIORITY IGNORE INTO $new_tbl->{name} "
. "(" . join(', ', map { $q->quote($_->{new}) } @common_cols) . ") "
. "SELECT";
my $select = join(', ', map { $q->quote($_->{old}) } @common_cols);
# The chunk size is auto-adjusted, so use --chunk-size as
# the initial value, but then save and update the adjusted
# chunk size in the table data struct.
$orig_tbl->{chunk_size} = $o->get('chunk-size');
# This won't (shouldn't) fail because we already verified in
# check_orig_table() table we can NibbleIterator::can_nibble().
my $nibble_iter = new NibbleIterator(
Cxn => $cxn,
tbl => $orig_tbl,
chunk_size => $orig_tbl->{chunk_size},
chunk_index => $o->get('chunk-index'),
n_chunk_index_cols => $o->get('chunk-index-columns'),
dml => $dml,
select => $select,
callbacks => $callbacks,
lock_in_share_mode => $lock_in_share_mode,
OptionParser => $o,
Quoter => $q,
TableParser => $tp,
TableNibbler => new TableNibbler(TableParser => $tp, Quoter => $q),
comments => {
bite => "pt-online-schema-change $PID copy table",
nibble => "pt-online-schema-change $PID copy nibble",
},
);
# Init a new weighted avg rate calculator for the table.
$orig_tbl->{rate} = new WeightedAvgRate(target_t => $chunk_time);
# Make a Progress obj for this table. It may not be used;
# depends on how many rows, chunk size, how fast the server
# is, etc. But just in case, all tables have a Progress obj.
if ( $o->get('progress')
&& !$nibble_iter->one_nibble()
&& $nibble_iter->row_estimate() )
{
$orig_tbl->{progress} = new Progress(
jobsize => $nibble_iter->row_estimate(),
spec => $o->get('progress'),
name => "Copying $orig_tbl->{name}",
);
}
# --plugin hook
if ( $plugin && $plugin->can('before_copy_rows') ) {
$plugin->before_copy_rows();
}
# Start copying rows. This may take awhile, but --progress is on
# by default so there will be progress updates to stderr.
eval {
1 while $nibble_iter->next();
};
if ( $EVAL_ERROR ) {
die ts("Error copying rows from $orig_tbl->{name} to "
. "$new_tbl->{name}: $EVAL_ERROR\n");
}
$orig_tbl->{copied} = 1; # flag for cleanup tasks
# XXX Auto-choose the alter fk method BEFORE swapping/renaming tables
# else everything will break because if drop_swap is chosen, then we
# most NOT rename tables or drop the old table.
if ( $alter_fk_method eq 'auto' ) {
# If chunk time is set, then use the average rate of rows/s
# from copying the orig table to determine the max size of
# a child table that can be altered within one chunk time.
# The limit is a fudge factor. Chunk time won't be set if
# the user specified --chunk-size=N on the cmd line, in which
# case the max child table size is their specified chunk size
# times the fudge factor.
my $max_rows = $o->get('dry-run') ? $o->get('chunk-size') * $limit
: $chunk_time && $avg_rate ? $avg_rate * $chunk_time * $limit
: $o->get('chunk-size') * $limit;
PTDEBUG && _d('Max allowed child table size:', $max_rows);
$alter_fk_method = determine_alter_fk_method(
child_tables => $child_tables,
max_rows => $max_rows,
Cxn => $cxn,
OptionParser => $o,
);
if ( $alter_fk_method eq 'drop_swap' ) {
$o->set('swap-tables', 0);
$o->set('drop-old-table', 0);
}
}
# --plugin hook
if ( $plugin && $plugin->can('after_copy_rows') ) {
$plugin->after_copy_rows();
}
# #####################################################################
# XXX
# Step 5: Rename tables: orig -> old, new -> orig
# Past this step, the original table has been altered. This shouldn't
# fail, but if it does, the failure could be serious depending on what
# state the tables are left in.
# XXX
# #####################################################################
# --plugin hook
if ( $plugin && $plugin->can('before_swap_tables') ) {
$plugin->before_swap_tables();
}
my $old_tbl;
if ( $o->get('swap-tables') ) {
eval {
$old_tbl = swap_tables(
orig_tbl => $orig_tbl,
new_tbl => $new_tbl,
suffix => '_old',
Cxn => $cxn,
Quoter => $q,
OptionParser => $o,
Retry => $retry,
tries => $tries,
stats => \%stats,
analyze_table => $analyze_table,
);
};
if ( $EVAL_ERROR ) {
# TODO: one of these values can be undefined
die ts("Error swapping tables: $EVAL_ERROR\n"
. "To clean up, first verify that the original table "
. "$orig_tbl->{name} has not been modified or renamed, "
. "then drop the new table $new_tbl->{name} if it exists.\n");
}
}
$orig_tbl->{swapped} = 1; # flag for cleanup tasks
PTDEBUG && _d('Old table:', Dumper($old_tbl));
# --plugin hook
if ( $plugin && $plugin->can('after_swap_tables') ) {
$plugin->after_swap_tables(
old_tbl => $old_tbl,
);
}
# #####################################################################
# Step 6: Update foreign key constraints if there are child tables.
# #####################################################################
if ( $child_tables ) {
# --plugin hook
if ( $plugin && $plugin->can('before_update_foreign_keys') ) {
$plugin->before_update_foreign_keys();
}
eval {
if ( $alter_fk_method eq 'none' ) {
# This shouldn't happen, but in case it does we should know.
warn "The tool detected child tables but "
. "--alter-foreign-keys-method=none";
}
elsif ( $alter_fk_method eq 'rebuild_constraints' ) {
rebuild_constraints(
orig_tbl => $orig_tbl,
old_tbl => $old_tbl,
child_tables => $child_tables,
OptionParser => $o,
Quoter => $q,
Cxn => $cxn,
TableParser => $tp,
stats => \%stats,
Retry => $retry,
tries => $tries,
);
}
elsif ( $alter_fk_method eq 'drop_swap' ) {
drop_swap(
orig_tbl => $orig_tbl,
new_tbl => $new_tbl,
Cxn => $cxn,
OptionParser => $o,
stats => \%stats,
Retry => $retry,
tries => $tries,
analyze_table => $analyze_table,
);
}
elsif ( !$alter_fk_method
&& $o->has('alter-foreign-keys-method')
&& ($o->get('alter-foreign-keys-method') || '') eq 'auto' ) {
# If --alter-foreign-keys-method is 'auto' and we are on a dry run,
# $alter_fk_method is left as an empty string.
print "Not updating foreign key constraints because this is a dry run.\n";
}
else {
# This should "never" happen because we check this var earlier.
die "Invalid --alter-foreign-keys-method: $alter_fk_method\n";
}
};
if ( $EVAL_ERROR ) {
# TODO: improve error message and handling.
die "Error updating foreign key constraints: $EVAL_ERROR\n";
}
# --plugin hook
if ( $plugin && $plugin->can('after_update_foreign_keys') ) {
$plugin->after_update_foreign_keys();
}
}
# ########################################################################
# Step 7: Drop the old table.
# ########################################################################
if ( $o->get('drop-old-table') ) {
if ( $o->get('dry-run') ) {
print "Not dropping old table because this is a dry run.\n";
}
elsif ( !$old_tbl ) {
print "Not dropping old table because --no-swap-tables was specified.\n";
}
else {
# --plugin hook
if ( $plugin && $plugin->can('before_drop_old_table') ) {
$plugin->before_drop_old_table();
}
print ts("Dropping old table...\n");
if ( $alter_fk_method eq 'none' ) {
# Child tables still reference the old table, but the user
# has chosen to break fks, so we need to disable fk checks
# in order to drop the old table.
my $sql = "SET foreign_key_checks=0";
PTDEBUG && _d($sql);
print $sql, "\n" if $o->get('print');
$cxn->dbh()->do($sql);
}
my $sql = "DROP TABLE IF EXISTS $old_tbl->{name}";
print $sql, "\n" if $o->get('print');
PTDEBUG && _d($sql);
eval {
$cxn->dbh()->do($sql);
};
if ( $EVAL_ERROR ) {
die ts("Error dropping the old table: $EVAL_ERROR\n");
}
print ts("Dropped old table $old_tbl->{name} OK.\n");
# --plugin hook
if ( $plugin && $plugin->can('after_drop_old_table') ) {
$plugin->after_drop_old_table();
}
}
}
elsif ( !$drop_triggers ) {
print "Not dropping old table because --no-drop-triggers was specified.\n";
}
else {
print "Not dropping old table because --no-drop-old-table was specified.\n";
}
# ########################################################################
# Done.
# ########################################################################
$orig_tbl->{success} = 1; # flag for cleanup tasks
$cleanup = undef; # exec cleanup tasks
# --plugin hook
if ( $plugin && $plugin->can('before_exit') ) {
$plugin->before_exit(
exit_status => $exit_status,
);
}
return $exit_status;
}
# ############################################################################
# Subroutines.
# ############################################################################
sub validate_tries {
my ($o) = @_;
my @ops = qw(
create_triggers
drop_triggers
copy_rows
swap_tables
update_foreign_keys
analyze_table
);
my %user_tries;
my $user_tries = $o->get('tries');
if ( $user_tries ) {
foreach my $var_val ( @$user_tries ) {
my ($op, $tries, $wait) = split(':', $var_val);
die "Invalid --tries value: $var_val\n" unless $op && $tries && $wait;
die "Invalid --tries operation: $op\n" unless grep { $op eq $_ } @ops;
die "Invalid --tries tries: $tries\n" unless $tries > 0;
die "Invalid --tries wait: $wait\n" unless $wait > 0;
$user_tries{$op} = {
tries => $tries,
wait => $wait,
};
}
}
my %default_tries;
my $default_tries = $o->read_para_after(__FILE__, qr/MAGIC_tries/);
if ( $default_tries ) {
%default_tries = map {
my $var_val = $_;
my ($op, $tries, $wait) = $var_val =~ m/(\S+)/g;
die "Invalid --tries value: $var_val\n" unless $op && $tries && $wait;
die "Invalid --tries operation: $op\n" unless grep { $op eq $_ } @ops;
die "Invalid --tries tries: $tries\n" unless $tries > 0;
die "Invalid --tries wait: $wait\n" unless $wait > 0;
$op => {
tries => $tries,
wait => $wait,
};
} grep { m/^\s+\w+\s+\d+\s+[\d\.]+/ } split("\n", $default_tries);
}
my %tries = (
%default_tries, # first the tool's defaults
%user_tries, # then the user's which overwrite the defaults
);
PTDEBUG && _d('--tries:', Dumper(\%tries));
return \%tries;
}
sub check_alter {
my (%args) = @_;
my @required_args = qw(alter tbl dry_run Cxn TableParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless exists $args{$arg};
}
my ($alter, $tbl, $dry_run, $cxn, $tp) = @args{@required_args};
my $ok = 1;
# ########################################################################
# Check for DROP PRIMARY KEY.
# ########################################################################
if ( $alter =~ m/DROP\s+PRIMARY\s+KEY/i ) {
my $msg = "--alter contains 'DROP PRIMARY KEY'. Dropping and "
. "altering the primary key can be dangerous, "
. "especially if the original table does not have other "
. "unique indexes.\n";
if ( $dry_run ) {
print $msg;
}
else {
$ok = 0;
warn $msg
. "The tool should handle this correctly, but you should "
. "test it first and carefully examine the triggers which "
. "rely on the PRIMARY KEY or a unique index. Specify "
. "--no-check-alter to disable this check and perform the "
. "--alter.\n";
}
}
# ########################################################################
# Check for renamed columns.
# https://bugs.launchpad.net/percona-toolkit/+bug/1068562
# ########################################################################
my $renamed_cols = $args{renamed_cols};
if ( %$renamed_cols ) {
# sort is just for making output consistent for testing
my $msg = "--alter appears to rename these columns:\n"
. join("\n", map { " $_ to $renamed_cols->{$_}" }
sort keys %$renamed_cols)
. "\n";
if ( $dry_run ) {
print $msg;
}
else {
$ok = 0;
warn $msg
. "The tool should handle this correctly, but you should "
. "test it first because if it fails the renamed columns' "
. "data will be lost! Specify --no-check-alter to disable "
. "this check and perform the --alter.\n";
}
}
# ########################################################################
# If it's a cluster node, check for MyISAM which does not work.
# ########################################################################
my $cluster = Percona::XtraDB::Cluster->new;
if ( $cluster->is_cluster_node($cxn) ) {
if ( ($tbl->{tbl_struct}->{engine} || '') =~ m/MyISAM/i ) {
$ok = 0;
warn $cxn->name . " is a cluster node and the table is MyISAM, "
. "but MyISAM tables "
. "do not work with clusters and this tool. To alter the "
. "table, you must manually convert it to InnoDB first.\n";
}
elsif ( $alter =~ m/ENGINE=MyISAM/i ) {
$ok = 0;
warn $cxn->name . " is a cluster node and the table is being "
. "converted to MyISAM (ENGINE=MyISAM), but MyISAM tables "
. "do not work with clusters and this tool. To alter the "
. "table, you must manually convert it to InnoDB first.\n";
}
}
if ( !$ok ) {
# check_alter.t relies on this output.
die "--check-alter failed.\n";
}
return;
}
sub find_renamed_cols {
my (%args) = @_;
my @required_args = qw(alter TableParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($alter, $tp) = @args{@required_args};
my $unquoted_ident = qr/
(?!\p{Digit}+[.\s]) # Not all digits
[0-9a-zA-Z_\x{80}-\x{FFFF}\$]+ # As per the spec
/x;
my $quoted_ident = do {
my $quoted_ident_character = qr/
[\x{01}-\x{5F}\x{61}-\x{FFFF}] # Any character but the null byte and `
/x;
qr{
# The following alternation is there because something like (?<=.)
# would match if this regex was used like /.$re/,
# or even more tellingly, would match on "``" =~ /`$re`/
$quoted_ident_character+ # One or more characters
(?:``$quoted_ident_character*)* # possibly followed by `` and
# more characters, zero or more times
|$quoted_ident_character* # OR, zero or more characters
(?:``$quoted_ident_character* )+ # Followed by `` and maybe more
# characters, one or more times.
}x
};
my $ansi_quotes_ident = qr/
[^"]+ (?: "" [^"]* )*
| [^"]* (?: "" [^"]* )+
/x;
my $table_ident = qr/$unquoted_ident|`$quoted_ident`|"$ansi_quotes_ident"/;
my $alter_change_col_re = qr/\bCHANGE \s+ (?:COLUMN \s+)?
($table_ident) \s+ ($table_ident)/ix;
my %renames;
while ( $alter =~ /$alter_change_col_re/g ) {
my ($orig, $new) = map { $tp->ansi_to_legacy($_) } $1, $2;
next unless $orig && $new;
my (undef, $orig_tbl) = Quoter->split_unquote($orig);
my (undef, $new_tbl) = Quoter->split_unquote($new);
# Silly but plausible: CHANGE COLUMN same_name same_name ...
next if lc($orig_tbl) eq lc($new_tbl);
$renames{$orig_tbl} = $new_tbl;
}
PTDEBUG && _d("Renamed columns (old => new): ", Dumper(\%renames));
return \%renames;
}
sub nibble_is_safe {
my (%args) = @_;
my @required_args = qw(Cxn tbl NibbleIterator OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn, $tbl, $nibble_iter, $o)= @args{@required_args};
# EXPLAIN the checksum chunk query to get its row estimate and index.
# XXX This call and others like it are relying on a Perl oddity.
# See https://bugs.launchpad.net/percona-toolkit/+bug/987393
my $sth = $nibble_iter->statements();
my $boundary = $nibble_iter->boundaries();
my $expl = explain_statement(
tbl => $tbl,
sth => $sth->{explain_nibble},
vals => [ @{$boundary->{lower}}, @{$boundary->{upper}} ],
);
# Ensure that MySQL is using the chunk index if the table is being chunked.
# Skip if --nocheck-plan See: https://bugs.launchpad.net/percona-toolkit/+bug/1340728
if ( !$nibble_iter->one_nibble()
&& lc($expl->{key} || '') ne lc($nibble_iter->nibble_index() || '')
&& $o->get('check-plan') )
{
die ts("Error copying rows at chunk " . $nibble_iter->nibble_number()
. " of $tbl->{db}.$tbl->{tbl} because MySQL chose "
. ($expl->{key} ? "the $expl->{key}" : "no") . " index "
. " instead of the " . $nibble_iter->nibble_index() . "index.\n");
}
# Ensure that the chunk isn't too large if there's a --chunk-size-limit.
# If single-chunking the table, this has already been checked, so it
# shouldn't have changed. If chunking the table with a non-unique key,
# oversize chunks are possible.
if ( my $limit = $o->get('chunk-size-limit') ) {
my $oversize_chunk
= $limit ? ($expl->{rows} || 0) >= $tbl->{chunk_size} * $limit
: 0;
if ( $oversize_chunk
&& $nibble_iter->identical_boundaries($boundary->{upper},
$boundary->{next_lower}) )
{
die ts("Error copying rows at chunk " . $nibble_iter->nibble_number()
. " of $tbl->{db}.$tbl->{tbl} because it is oversized. "
. "The current chunk size limit is "
. ($tbl->{chunk_size} * $limit)
. " rows (chunk size=$tbl->{chunk_size}"
. " * chunk size limit=$limit), but MySQL estimates "
. "that there are " . ($expl->{rows} || 0)
. " rows in the chunk.\n");
}
}
# Ensure that MySQL is still using the entire index.
# https://bugs.launchpad.net/percona-toolkit/+bug/1010232
# Skip if --nocheck-plan See: https://bugs.launchpad.net/percona-toolkit/+bug/1340728
if ( !$nibble_iter->one_nibble()
&& $tbl->{key_len}
&& ($expl->{key_len} || 0) < $tbl->{key_len}
&& $o->get('check-plan') )
{
die ts("Error copying rows at chunk " . $nibble_iter->nibble_number()
. " of $tbl->{db}.$tbl->{tbl} because MySQL used "
. "only " . ($expl->{key_len} || 0) . " bytes "
. "of the " . ($expl->{key} || '?') . " index instead of "
. $tbl->{key_len} . ". See the --[no]check-plan documentation "
. "for more information.\n");
}
return 1; # safe
}
sub create_new_table {
my (%args) = @_;
my @required_args = qw(new_table_name orig_tbl Cxn Quoter OptionParser TableParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($new_table_name, $orig_tbl, $cxn, $q, $o, $tp) = @args{@required_args};
my $new_table_prefix = $args{new_table_prefix};
# Get the original table struct.
my $ddl = $tp->get_create_table(
$cxn->dbh(),
$orig_tbl->{db},
$orig_tbl->{tbl},
);
$new_table_name =~ s/%T/$orig_tbl->{tbl}/;
print "Creating new table...\n";
my $tries = $new_table_prefix ? 10 : 1;
my $tryno = 1;
my @old_tables;
while ( $tryno++ <= $tries ) {
if ( $new_table_prefix ) {
$new_table_name = $new_table_prefix . $new_table_name;
}
if ( length($new_table_name) > 64 ) {
my $truncated_table_name = substr($new_table_name, 0, 64);
PTDEBUG && _d($new_table_name, 'is over 64 characters long, '
. 'truncating to', $truncated_table_name);
$new_table_name = $truncated_table_name;
}
# Generate SQL to create the new table. We do not use CREATE TABLE LIKE
# because it doesn't preserve foreign key constraints. Here we need to
# rename the FK constraints, too. This is because FK constraints are
# internally stored as . and there cannot be
# duplicates. If we don't rename the constraints, then InnoDB will throw
# error 121 (duplicate key violation) when we try to execute the CREATE
# TABLE. TODO: this code isn't perfect. If we rename a constraint from
# foo to _foo and there is already a constraint with that name in this
# or another table, we can still have a collision. But if there are
# multiple FKs on this table, it's hard to know which one is causing the
# trouble. Should we generate random/UUID FK names or something instead?
my $quoted = $q->quote($orig_tbl->{db}, $new_table_name);
my $sql = $ddl;
$sql =~ s/\ACREATE TABLE .*?\($/CREATE TABLE $quoted (/m;
# If it has a leading underscore, we remove one, otherwise we add one
# This is in contrast to previous behavior were we added underscores
# indefinitely, sometimes exceeding the allowed name limit
# https://bugs.launchpad.net/percona-toolkit/+bug/1215587
if ( $sql =~ /CONSTRAINT `_/ ) {
$sql =~ s/^ CONSTRAINT `_/ CONSTRAINT `/gm;
} else {
$sql =~ s/^ CONSTRAINT `/ CONSTRAINT `_/gm;
}
if ( $o->get('default-engine') ) {
$sql =~ s/\s+ENGINE=\S+//;
}
PTDEBUG && _d($sql);
eval {
$cxn->dbh()->do($sql);
};
if ( $EVAL_ERROR ) {
# Ignore this error because if multiple instances of the tool
# are running, or previous runs failed and weren't cleaned up,
# then there will be other similarly named tables with fewer
# leading prefix chars. Or, in rarer cases, the db just happens
# to have a similarly named table created by the user for other
# purposes.
if ( $EVAL_ERROR =~ m/table.+?already exists/i ) {
push @old_tables, $q->quote($orig_tbl->{db}, $new_table_name);
next;
}
# Some other error happened. Let the caller catch it.
die $EVAL_ERROR;
}
print $sql, "\n" if $o->get('print'); # the sql that work
print "Created new table $orig_tbl->{db}.$new_table_name OK.\n";
return { # success
db => $orig_tbl->{db},
tbl => $new_table_name,
name => $q->quote($orig_tbl->{db}, $new_table_name),
};
}
die "Failed to find a unique new table name after $tries attemps. "
. "The following tables exist which may be left over from previous "
. "failed runs of the tool:\n"
. join("\n", map { " $_" } @old_tables)
. "\nExamine these tables and drop some or all of them if they are "
. "no longer need, then re-run the tool.\n";
}
sub swap_tables {
my (%args) = @_;
my @required_args = qw(orig_tbl new_tbl Cxn Quoter OptionParser Retry tries stats);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($orig_tbl, $new_tbl, $cxn, $q, $o, $retry, $tries, $stats) = @args{@required_args};
my $prefix = '_';
my $table_name = $orig_tbl->{tbl} . ($args{suffix} || '');
my $name_tries = 10; # don't try forever
my $table_exists = qr/table.+?already exists/i;
# This sub only works for --execute. Since the options are
# mutually exclusive and we return in the if case, the elsif
# is just a paranoid check because swapping the tables is one
# of the most sensitive/dangerous operations.
if ( $o->get('dry-run') ) {
print "Not swapping tables because this is a dry run.\n";
# A return value really isn't needed, but this trick allows
# rebuild_constraints() to parse and show the sql statements
# it would used. Otherwise, this has no effect.
return $orig_tbl;
}
elsif ( $o->get('execute') ) {
# ANALYZE TABLE before renaming to update InnoDB optimizer statistics.
# https://bugs.launchpad.net/percona-toolkit/+bug/1491261
if ( $args{analyze_table} ) {
print ts("Analyzing new table...\n");
my $sql_analyze = "ANALYZE TABLE $new_tbl->{name} /* pt-online-schema-change */";
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{analyze_table},
stats => $stats,
code => sub {
PTDEBUG && _d($sql_analyze);
$cxn->dbh()->do($sql_analyze);
},
);
}
print ts("Swapping tables...\n");
while ( $name_tries-- ) {
$table_name = $prefix . $table_name;
if ( length($table_name) > 64 ) {
my $truncated_table_name = substr($table_name, 0, 64);
PTDEBUG && _d($table_name, 'is > 64 chars, truncating to',
$truncated_table_name);
$table_name = $truncated_table_name;
}
my $sql = "RENAME TABLE $orig_tbl->{name} "
. "TO " . $q->quote($orig_tbl->{db}, $table_name)
. ", $new_tbl->{name} TO $orig_tbl->{name}";
eval {
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{swap_tables},
stats => $stats,
code => sub {
PTDEBUG && _d($sql);
$cxn->dbh()->do($sql);
},
ignore_errors => [
# Ignore this error because if multiple instances of the tool
# are running, or previous runs failed and weren't cleaned up,
# then there will be other similarly named tables with fewer
# leading prefix chars. Or, in rare cases, the db happens
# to have a similarly named table created by the user for
# other purposes.
$table_exists,
],
);
};
if ( my $e = $EVAL_ERROR ) {
if ( $e =~ $table_exists ) {
PTDEBUG && _d($e);
next;
}
die ts($e);
}
print $sql, "\n" if $o->get('print');
print ts("Swapped original and new tables OK.\n");
return { # success
db => $orig_tbl->{db},
tbl => $table_name,
name => $q->quote($orig_tbl->{db}, $table_name),
};
}
# This shouldn't happen.
# Here and in the attempt to find a new table name we probably ought to
# use --tries (and maybe a Retry object?)
die ts("Failed to find a unique old table name after "
. "serveral attempts.\n");
}
}
sub check_orig_table {
my ( %args ) = @_;
my @required_args = qw(orig_tbl Cxn TableParser OptionParser Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($orig_tbl, $cxn, $tp, $o, $q) = @args{@required_args};
my $dbh = $cxn->dbh();
# The original table must exist, of course.
if (!$tp->check_table(dbh=>$dbh,db=>$orig_tbl->{db},tbl=>$orig_tbl->{tbl})) {
die "The original table $orig_tbl->{name} does not exist.\n";
}
# There cannot be any triggers on the original table.
my $sql = 'SHOW TRIGGERS FROM ' . $q->quote($orig_tbl->{db})
. ' LIKE ' . $q->literal_like($orig_tbl->{tbl});
PTDEBUG && _d($sql);
my $triggers = $dbh->selectall_arrayref($sql);
if ( $triggers && @$triggers ) {
die "The table $orig_tbl->{name} has triggers. This tool "
. "needs to create its own triggers, so the table cannot "
. "already have triggers.\n";
}
# Get the table struct. NibbleIterator needs this, and so do we.
my $ddl = $tp->get_create_table(
$cxn->dbh(),
$orig_tbl->{db},
$orig_tbl->{tbl},
);
$orig_tbl->{tbl_struct} = $tp->parse($ddl);
# Must be able to nibble the original table (to copy rows to the new table).
eval {
NibbleIterator::can_nibble(
Cxn => $cxn,
tbl => $orig_tbl,
chunk_size => $o->get('chunk-size'),
chunk_indx => $o->get('chunk-index'),
OptionParser => $o,
TableParser => $tp,
);
};
if ( $EVAL_ERROR ) {
die "Cannot chunk the original table $orig_tbl->{name}: $EVAL_ERROR\n";
}
return; # success
}
sub find_child_tables {
my ( %args ) = @_;
my @required_args = qw(tbl Cxn Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($tbl, $cxn, $q) = @args{@required_args};
if ( lc($tbl->{tbl_struct}->{engine} || '') eq 'myisam' ) {
PTDEBUG && _d(q{MyISAM table, not looking for child tables});
return;
}
PTDEBUG && _d('Finding child tables');
my $sql = "SELECT table_schema, table_name "
. "FROM information_schema.key_column_usage "
. "WHERE referenced_table_schema='$tbl->{db}' "
. "AND referenced_table_name='$tbl->{tbl}'";
PTDEBUG && _d($sql);
my $rows = $cxn->dbh()->selectall_arrayref($sql);
if ( !$rows || !@$rows ) {
PTDEBUG && _d('No child tables found');
return;
}
my @child_tables;
foreach my $row ( @$rows ) {
my $tbl = {
db => $row->[0],
tbl => $row->[1],
name => $q->quote(@$row),
};
# Get row estimates for each child table so we can give the user
# some input on choosing an --alter-foreign-keys-method if they
# don't use "auto".
my ($n_rows) = NibbleIterator::get_row_estimate(
Cxn => $cxn,
tbl => $tbl,
);
$tbl->{row_est} = $n_rows;
push @child_tables, $tbl;
}
PTDEBUG && _d('Child tables:', Dumper(\@child_tables));
return \@child_tables;
}
sub determine_alter_fk_method {
my ( %args ) = @_;
my @required_args = qw(child_tables max_rows Cxn OptionParser);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($child_tables, $max_rows, $cxn, $o) = @args{@required_args};
if ( $o->get('dry-run') ) {
print "Not determining the method to update foreign keys "
. "because this is a dry run.\n";
return ''; # $alter_fk_method can't be undef
}
# The rebuild_constraints method is the default becuase it's safer
# and doesn't cause the orig table to go missing for a moment.
my $method = 'rebuild_constraints';
print ts("Max rows for the rebuild_constraints method: $max_rows\n"
. "Determining the method to update foreign keys...\n");
foreach my $child_tbl ( @$child_tables ) {
print ts(" $child_tbl->{name}: ");
my ($n_rows) = NibbleIterator::get_row_estimate(
Cxn => $cxn,
tbl => $child_tbl,
);
if ( $n_rows > $max_rows ) {
print "too many rows: $n_rows; must use drop_swap\n";
$method = 'drop_swap';
last;
}
else {
print "$n_rows rows; can use rebuild_constraints\n";
}
}
return $method || ''; # $alter_fk_method can't be undef
}
sub rebuild_constraints {
my ( %args ) = @_;
my @required_args = qw(orig_tbl old_tbl child_tables stats
Cxn Quoter OptionParser TableParser
Retry tries);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($orig_tbl, $old_tbl, $child_tables, $stats, $cxn, $q, $o, $tp, $retry, $tries)
= @args{@required_args};
# MySQL has a "feature" where if the parent tbl is in the same db,
# then the child tbl ref is simply `parent_tbl`, but if the parent tbl
# is in another db, then the child tbl ref is `other_db`.`parent_tbl`.
# When we recreate the ref below, we use the db-qualified form, and
# MySQL will automatically trim the db if the tables are in the same db.
my $quoted_old_table = $q->quote($old_tbl->{tbl});
my $constraint = qr/
^\s+
(
CONSTRAINT.+?
REFERENCES\s(?:$quoted_old_table|$old_tbl->{name})
.+
)$
/xm;
PTDEBUG && _d('Rebuilding fk constraint matching', $constraint);
if ( $o->get('dry-run') ) {
print "Not rebuilding foreign key constraints because this is a dry run.\n";
}
else {
print ts("Rebuilding foreign key constraints...\n");
}
CHILD_TABLE:
foreach my $child_tbl ( @$child_tables ) {
my $table_def = $tp->get_create_table(
$cxn->dbh(),
$child_tbl->{db},
$child_tbl->{tbl},
);
my @constraints = $table_def =~ m/$constraint/g;
if ( !@constraints ) {
warn ts("$child_tbl->{name} has no foreign key "
. "constraints referencing $old_tbl->{name}.\n");
next CHILD_TABLE;
}
my @rebuilt_constraints;
foreach my $constraint ( @constraints ) {
PTDEBUG && _d('Rebuilding fk constraint:', $constraint);
# Remove trailing commas in case there are multiple constraints on the
# table.
$constraint =~ s/,$//;
# Find the constraint name. It will be quoted already.
my ($fk) = $constraint =~ m/CONSTRAINT\s+`([^`]+)`/;
# Drop the reference to the old table/renamed orig table, and add a new
# reference to the new table. InnoDB will throw an error if the new
# constraint has the same name as the old one, so we must rename it.
# Example: after renaming sakila.actor to sakila.actor_old (for
# example), the foreign key on film_actor looks like this:
# CONSTRAINT `fk_film_actor_actor` FOREIGN KEY (`actor_id`) REFERENCES
# `actor_old` (`actor_id`) ON UPDATE CASCADE
# We need it to look like this instead:
# CONSTRAINT `_fk_film_actor_actor` FOREIGN KEY (`actor_id`) REFERENCES
# `actor` (`actor_id`) ON UPDATE CASCADE
# Reference the correct table name...
$constraint =~ s/REFERENCES[^\(]+/REFERENCES $orig_tbl->{name} /;
# And rename the constraint to avoid conflict
# If it has a leading underscore, we remove one, otherwise we add one
# This is in contrast to previous behavior were we added underscores
# indefinitely, sometimes exceeding the allowed name limit
# https://bugs.launchpad.net/percona-toolkit/+bug/1215587
my $new_fk;
if ($fk =~ /^_/) {
($new_fk = $fk) =~ s/^_//;
}else {
$new_fk = '_'.$fk;
}
PTDEBUG && _d("Old FK name: $fk New FK name: $new_fk");
$constraint =~ s/CONSTRAINT `$fk`/CONSTRAINT `$new_fk`/;
my $sql = "DROP FOREIGN KEY `$fk`, "
. "ADD $constraint";
push @rebuilt_constraints, $sql;
}
my $sql = "ALTER TABLE $child_tbl->{name} "
. join(', ', @rebuilt_constraints);
print $sql, "\n" if $o->get('print');
if ( $o->get('execute') ) {
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{update_foreign_keys},
stats => $stats,
code => sub {
PTDEBUG && _d($sql);
$cxn->dbh()->do($sql);
$stats->{rebuilt_constraint}++;
},
);
}
}
if ( $o->get('execute') ) {
print ts("Rebuilt foreign key constraints OK.\n");
}
return;
}
sub drop_swap {
my ( %args ) = @_;
my @required_args = qw(orig_tbl new_tbl Cxn OptionParser stats Retry tries);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($orig_tbl, $new_tbl, $cxn, $o, $stats, $retry, $tries) = @args{@required_args};
if ( $o->get('dry-run') ) {
print "Not drop-swapping tables because this is a dry run.\n";
}
else {
print ts("Drop-swapping tables...\n");
}
# ANALYZE TABLE before renaming to update InnoDB optimizer statistics.
# https://bugs.launchpad.net/percona-toolkit/+bug/1491261
if ( $args{analyze_table} ) {
print ts("Analyzing new table...\n");
my $sql_analyze = "ANALYZE TABLE $new_tbl->{name} /* pt-online-schema-change */";
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{analyze_table},
stats => $stats,
code => sub {
PTDEBUG && _d($sql_analyze);
$cxn->dbh()->do($sql_analyze);
},
);
}
my @sqls = (
"SET foreign_key_checks=0",
"DROP TABLE IF EXISTS $orig_tbl->{name}",
"RENAME TABLE $new_tbl->{name} TO $orig_tbl->{name}",
);
# we don't want to be interrupted during the swap!
# since it might leave original table dropped
# https://bugs.launchpad.net/percona-toolkit/+bug/1368244
$dont_interrupt_now = 1;
foreach my $sql ( @sqls ) {
PTDEBUG && _d($sql);
print $sql, "\n" if $o->get('print');
if ( $o->get('execute') ) {
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{update_foreign_keys},
stats => $stats,
code => sub {
PTDEBUG && _d($sql);
$cxn->dbh()->do($sql);
},
);
}
}
$dont_interrupt_now = 0;
if ( $o->get('execute') ) {
print ts("Dropped and swapped tables OK.\n");
}
return;
}
sub create_triggers {
my ( %args ) = @_;
my @required_args = qw(orig_tbl new_tbl del_tbl columns Cxn Quoter OptionParser Retry tries stats);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($orig_tbl, $new_tbl, $del_tbl, $cols, $cxn, $q, $o, $retry, $tries, $stats) = @args{@required_args};
# This sub works for --dry-run and --execute. With --dry-run it's
# only interesting if --print is specified, too; then the user can
# see the create triggers statements for --execute.
if ( $o->get('dry-run') ) {
print "Not creating triggers because this is a dry run.\n";
}
else {
print ts("Creating triggers...\n");
}
# Create a unique trigger name prefix based on the orig table name
# so multiple instances of the tool can run on different tables.
my $prefix = 'pt_osc_' . $orig_tbl->{db} . '_' . $orig_tbl->{tbl};
$prefix =~ s/\W/_/g;
if ( length($prefix) > 60 ) {
my $truncated_prefix = substr($prefix, 0, 60);
PTDEBUG && _d('Trigger prefix', $prefix, 'is over 60 characters long,',
'truncating to', $truncated_prefix);
$prefix = $truncated_prefix;
}
# To be safe, the delete trigger must specify all the columns of the
# primary key/unique index. We use null-safe equals, because unique
# unique indexes can be nullable. Cols are from the new table and
# they may have been renamed
my %old_col_for = map { $_->{new} => $_->{old} } @$cols;
my $tbl_struct = $del_tbl->{tbl_struct};
my $del_index = $del_tbl->{del_index};
my $del_index_cols = join(" AND ", map {
my $new_col = $_;
my $old_col = $old_col_for{$new_col} || $new_col;
my $new_qcol = $q->quote($new_col);
my $old_qcol = $q->quote($old_col);
"$new_tbl->{name}.$new_qcol <=> OLD.$old_qcol"
} @{$tbl_struct->{keys}->{$del_index}->{cols}} );
my $delete_trigger
= "CREATE TRIGGER `${prefix}_del` AFTER DELETE ON $orig_tbl->{name} "
. "FOR EACH ROW "
. "DELETE IGNORE FROM $new_tbl->{name} "
. "WHERE $del_index_cols";
my $qcols = join(', ', map { $q->quote($_->{new}) } @$cols);
my $new_vals = join(', ', map { "NEW.".$q->quote($_->{old}) } @$cols);
my $insert_trigger
= "CREATE TRIGGER `${prefix}_ins` AFTER INSERT ON $orig_tbl->{name} "
. "FOR EACH ROW "
. "REPLACE INTO $new_tbl->{name} ($qcols) VALUES ($new_vals)";
my $update_trigger
= "CREATE TRIGGER `${prefix}_upd` AFTER UPDATE ON $orig_tbl->{name} "
. "FOR EACH ROW "
. "REPLACE INTO $new_tbl->{name} ($qcols) VALUES ($new_vals)";
my @triggers = (
['del', $delete_trigger],
['upd', $update_trigger],
['ins', $insert_trigger],
);
my @trigger_names;
@drop_trigger_sqls = ();
foreach my $trg ( @triggers ) {
my ($name, $sql) = @$trg;
print $sql, "\n" if $o->get('print');
if ( $o->get('execute') ) {
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{create_triggers},
stats => $stats,
code => sub {
PTDEBUG && _d($sql);
$cxn->dbh()->do($sql);
},
);
}
# Only save the trigger once it has been created
# (or faked to be created) so if the 2nd trigger
# fails to create, we know to only drop the 1st.
push @trigger_names, "${prefix}_$name";
push @drop_trigger_sqls,
"DROP TRIGGER IF EXISTS "
. $q->quote($orig_tbl->{db}, "${prefix}_$name") . ";";
}
if ( $o->get('execute') ) {
print ts("Created triggers OK.\n");
}
return @trigger_names;
}
sub drop_triggers {
my ( %args ) = @_;
my @required_args = qw(tbl Cxn Quoter OptionParser Retry tries stats);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($tbl, $cxn, $q, $o, $retry, $tries, $stats) = @args{@required_args};
# This sub works for --dry-run and --execute, although --dry-run is
# only interesting with --print so the user can see the drop trigger
# statements for --execute.
if ( $o->get('dry-run') ) {
print "Not dropping triggers because this is a dry run.\n";
}
else {
print ts("Dropping triggers...\n");
}
foreach my $sql ( @drop_trigger_sqls ) {
print $sql, "\n" if $o->get('print');
if ( $o->get('execute') ) {
eval {
osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{drop_triggers},
stats => $stats,
code => sub {
PTDEBUG && _d($sql);
$cxn->dbh()->do($sql);
},
);
};
if ( $EVAL_ERROR ) {
warn ts("Error dropping trigger: $EVAL_ERROR\n");
push @triggers_not_dropped, $sql;
$exit_status = 1;
}
}
}
if ( $o->get('execute') ) {
if ( !@triggers_not_dropped ) {
print ts("Dropped triggers OK.\n");
}
else {
warn ts("To try dropping the triggers again, execute:\n"
. join("\n", @triggers_not_dropped) . "\n");
}
}
return;
}
sub error_event {
my ($error) = @_;
return 'undefined_error' unless $error;
my $event
= $error =~ m/Lock wait timeout/ ? 'lock_wait_timeout'
: $error =~ m/Deadlock found/ ? 'deadlock'
: $error =~ m/execution was interrupted/ ? 'query_killed'
: $error =~ m/server has gone away/ ? 'lost_connection'
: $error =~ m/Lost connection/ ? 'connection_killed'
: 'unknown_error';
return $event;
}
sub osc_retry {
my (%args) = @_;
my @required_args = qw(Cxn Retry tries code stats);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my $cxn = $args{Cxn};
my $retry = $args{Retry};
my $tries = $args{tries};
my $code = $args{code};
my $stats = $args{stats};
my $ignore_errors = $args{ignore_errors};
return $retry->retry(
tries => $tries->{tries},
wait => sub { sleep ($tries->{wait} || 0.25) },
try => $code,
fail => sub {
my (%args) = @_;
my $error = $args{error};
PTDEBUG && _d('Retry fail:', $error);
if ( $ignore_errors ) {
return 0 if grep { $error =~ $_ } @$ignore_errors;
}
# The query failed/caused an error. If the error is one of these,
# then we can possibly retry.
if ( $error =~ m/Lock wait timeout exceeded/
|| $error =~ m/Deadlock found/
|| $error =~ m/Query execution was interrupted/
) {
# These errors/warnings can be retried, so don't print
# a warning yet; do that in final_fail.
$stats->{ error_event($error) }++;
return 1; # try again
}
elsif ( $error =~ m/MySQL server has gone away/
|| $error =~ m/Lost connection to MySQL server/
) {
# The 1st pattern means that MySQL itself died or was stopped.
# The 2nd pattern means that our cxn was killed (KILL ).
$stats->{ error_event($error) }++;
$cxn->connect(); # connect or die trying
return 1; # reconnected, try again
}
$stats->{retry_fail}++;
# At this point, either the error/warning cannot be retried,
# or we failed to reconnect. Don't retry; call final_fail.
return 0;
},
final_fail => sub {
my (%args) = @_;
my $error = $args{error};
# This die should be caught by the caller. Copying rows and
# the tool will stop, which is probably good because by this
# point the error or warning indicates that something is wrong.
$stats->{ error_event($error) }++;
die ts($error);
}
);
}
sub exec_nibble {
my (%args) = @_;
my @required_args = qw(Cxn tbl stats tries Retry NibbleIterator Quoter);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless $args{$arg};
}
my ($cxn, $tbl, $stats, $tries, $retry, $nibble_iter, $q)
= @args{@required_args};
my $sth = $nibble_iter->statements();
my $boundary = $nibble_iter->boundaries();
my $lb_quoted = $q->serialize_list(@{$boundary->{lower}});
my $ub_quoted = $q->serialize_list(@{$boundary->{upper}});
my $chunk = $nibble_iter->nibble_number();
my $chunk_index = $nibble_iter->nibble_index();
# Completely ignore these error codes.
my %ignore_code = (
# Error: 1592 SQLSTATE: HY000 (ER_BINLOG_UNSAFE_STATEMENT)
# Message: Statement may not be safe to log in statement format.
# Ignore this warning because we have purposely set statement-based
# replication.
1592 => 1,
# Error: 1062 SQLSTATE: 23000 ( ER_DUP_ENTRY )
# Message: Duplicate entry '%ld' for key '%s'
# MariaDB 5.5.28+ has this as a warning; See https://bugs.launchpad.net/percona-toolkit/+bug/1099836
1062 => 1,
);
# Warn once per-table for these error codes if the error message
# matches the pattern.
my %warn_code = (
# Error: 1265 SQLSTATE: 01000 (WARN_DATA_TRUNCATED)
# Message: Data truncated for column '%s' at row %ld
1265 => {
# any pattern
# use MySQL's message for this warning
},
);
return osc_retry(
Cxn => $cxn,
Retry => $retry,
tries => $tries->{copy_rows},
stats => $stats,
code => sub {
# ###################################################################
# Start timing the query.
# ###################################################################
my $t_start = time;
# Execute the INSERT..SELECT query.
PTDEBUG && _d($sth->{nibble}->{Statement},
'lower boundary:', @{$boundary->{lower}},
'upper boundary:', @{$boundary->{upper}});
$sth->{nibble}->execute(
# WHERE
@{$boundary->{lower}}, # upper boundary values
@{$boundary->{upper}}, # lower boundary values
);
my $t_end = time;
$stats->{INSERT}++;
# ###################################################################
# End timing the query.
# ###################################################################
# How many rows were inserted this time. Used for auto chunk sizing.
$tbl->{row_cnt} = $sth->{nibble}->rows();
# Check if query caused any warnings.
my $sql_warn = 'SHOW WARNINGS';
PTDEBUG && _d($sql_warn);
my $warnings = $cxn->dbh->selectall_arrayref($sql_warn, {Slice => {}});
foreach my $warning ( @$warnings ) {
my $code = ($warning->{code} || 0);
my $message = $warning->{message};
if ( $ignore_code{$code} ) {
$stats->{"mysql_warning_$code"}++;
PTDEBUG && _d('Ignoring warning:', $code, $message);
next;
}
elsif ( $warn_code{$code}
&& (!$warn_code{$code}->{pattern}
|| $message =~ m/$warn_code{$code}->{pattern}/) )
{
if ( !$stats->{"mysql_warning_$code"}++ ) { # warn once
warn "Copying rows caused a MySQL error $code: "
. ($warn_code{$code}->{message}
? $warn_code{$code}->{message}
: $message)
. "\nNo more warnings about this MySQL error will be "
. "reported. If --statistics was specified, "
. "mysql_warning_$code will list the total count of "
. "this MySQL error.\n";
}
}
else {
# This die will propagate to fail which will return 0
# and propagate it to final_fail which will die with
# this error message.
die "Copying rows caused a MySQL error $code:\n"
. " Level: " . ($warning->{level} || '') . "\n"
. " Code: " . ($warning->{code} || '') . "\n"
. " Message: " . ($warning->{message} || '') . "\n"
. " Query: " . $sth->{nibble}->{Statement} . "\n";
}
}
# Success: no warnings, no errors. Return nibble time.
return $t_end - $t_start;
},
);
}
# Sub: explain_statement
# EXPLAIN a statement.
#
# Required Arguments:
# * tbl - Standard tbl hashref
# * sth - Sth with EXLAIN
# * vals - Values for sth, if any
#
# Returns:
# Hashref with EXPLAIN plan
sub explain_statement {
my ( %args ) = @_;
my @required_args = qw(tbl sth vals);
foreach my $arg ( @required_args ) {
die "I need a $arg argument" unless defined $args{$arg};
}
my ($tbl, $sth, $vals) = @args{@required_args};
my $expl;
eval {
PTDEBUG && _d($sth->{Statement}, 'params:', @$vals);
$sth->execute(@$vals);
$expl = $sth->fetchrow_hashref();
$sth->finish();
};
if ( $EVAL_ERROR ) {
# This shouldn't happen.
die "Error executing " . $sth->{Statement} . ": $EVAL_ERROR\n";
}
PTDEBUG && _d('EXPLAIN plan:', Dumper($expl));
return $expl;
}
sub ts {
my ($msg) = @_;
my $ts = $ENV{PTTEST_FAKE_TS} ? 'TS' : Transformers::ts(int(time));
return $msg ? "$ts $msg" : $ts;
}
# Catches signals so we can exit gracefully.
sub sig_int {
my ( $signal ) = @_;
if ( $dont_interrupt_now ) {
# we're in the middle of something that shouldn't be interrupted
PTDEBUG && _d("Received Signal: \"$signal\" in middle of critical operation. Continuing anyway.");
return;
}
$oktorun = 0; # flag for cleanup tasks
print STDERR "# Exiting on SIG$signal.\n";
# This is to restore terminal to "normal". lp #1396870
if ($term_readkey) {
ReadMode(0);
}
exit 1;
}
sub _d {
my ($package, undef, $line) = caller 0;
@_ = map { (my $temp = $_) =~ s/\n/\n# /g; $temp; }
map { defined $_ ? $_ : 'undef' }
@_;
print STDERR "# $package:$line $PID ", join(' ', @_), "\n";
}
# ############################################################################
# Run the program.
# ############################################################################
if ( !caller ) { exit main(@ARGV); }
1; # Because this is a module as well as a script.
# ############################################################################
# Documentation
# ############################################################################
=pod
=head1 NAME
pt-online-schema-change - ALTER tables without locking them.
=head1 SYNOPSIS
Usage: pt-online-schema-change [OPTIONS] DSN
pt-online-schema-change alters a table's structure without blocking reads or
writes. Specify the database and table in the DSN. Do not use this tool before
reading its documentation and checking your backups carefully.
Add a column to sakila.actor:
pt-online-schema-change --alter "ADD COLUMN c1 INT" D=sakila,t=actor
Change sakila.actor to InnoDB, effectively performing OPTIMIZE TABLE in a
non-blocking fashion because it is already an InnoDB table:
pt-online-schema-change --alter "ENGINE=InnoDB" D=sakila,t=actor
=head1 RISKS
Percona Toolkit is mature, proven in the real world, and well tested,
but all database tools can pose a risk to the system and the database
server. Before using this tool, please:
=over
=item * Read the tool's documentation
=item * Review the tool's known L<"BUGS">
=item * Test the tool on a non-production server
=item * Backup your production server and verify the backups
=back
=head1 DESCRIPTION
pt-online-schema-change emulates the way that MySQL alters tables internally,
but it works on a copy of the table you wish to alter. This means that the
original table is not locked, and clients may continue to read and change data
in it.
pt-online-schema-change works by creating an empty copy of the table to alter,
modifying it as desired, and then copying rows from the original table into the
new table. When the copy is complete, it moves away the original table and
replaces it with the new one. By default, it also drops the original table.
The data copy process is performed in small chunks of data, which are varied to
attempt to make them execute in a specific amount of time (see
L<"--chunk-time">). This process is very similar to how other tools, such as
pt-table-checksum, work. Any modifications to data in the original tables
during the copy will be reflected in the new table, because the tool creates
triggers on the original table to update the corresponding rows in the new
table. The use of triggers means that the tool will not work if any triggers
are already defined on the table.
When the tool finishes copying data into the new table, it uses an atomic
C operation to simultaneously rename the original and new tables.
After this is complete, the tool drops the original table.
Foreign keys complicate the tool's operation and introduce additional risk. The
technique of atomically renaming the original and new tables does not work when
foreign keys refer to the table. The tool must update foreign keys to refer to
the new table after the schema change is complete. The tool supports two methods
for accomplishing this. You can read more about this in the documentation for
L<"--alter-foreign-keys-method">.
Foreign keys also cause some side effects. The final table will have the same
foreign keys and indexes as the original table (unless you specify differently
in your ALTER statement), but the names of the objects may be changed slightly
to avoid object name collisions in MySQL and InnoDB.
For safety, the tool does not modify the table unless you specify the
L<"--execute"> option, which is not enabled by default. The tool supports a
variety of other measures to prevent unwanted load or other problems, including
automatically detecting replicas, connecting to them, and using the following
safety checks:
=over
=item *
In most cases the tool will refuse to operate unless a PRIMARY KEY or UNIQUE INDEX is
present in the table. See L<"--alter"> for details.
=item *
The tool refuses to operate if it detects replication filters. See
L<"--[no]check-replication-filters"> for details.
=item *
The tool pauses the data copy operation if it observes any replicas that are
delayed in replication. See L<"--max-lag"> for details.
=item *
The tool pauses or aborts its operation if it detects too much load on the
server. See L<"--max-load"> and L<"--critical-load"> for details.
=item *
The tool sets C and (for MySQL 5.5 and newer)
C so that it is more likely to be the victim of any
lock contention, and less likely to disrupt other transactions. These
values can be changed by specifying L<"--set-vars">.
=item *
The tool refuses to alter the table if foreign key constraints reference it,
unless you specify L<"--alter-foreign-keys-method">.
=item *
The tool cannot alter MyISAM tables on L<"Percona XtraDB Cluster"> nodes.
=back
=head1 Percona XtraDB Cluster
pt-online-schema-change works with Percona XtraDB Cluster (PXC) 5.5.28-23.7
and newer, but there are two limitations: only InnoDB tables can be altered,
and C must be set to C (total order isolation).
The tool exits with an error if the host is a cluster node and the table
is MyISAM or is being converted to MyISAM (C), or if
C is not C. There is no way to disable these checks.
=head1 OUTPUT
The tool prints information about its activities to STDOUT so that you can see
what it is doing. During the data copy phase, it prints L<"--progress">
reports to STDERR. You can get additional information by specifying
L<"--print">.
If L<"--statistics"> is specified, a report of various internal event counts
is printed at the end, like:
# Event Count
# ====== =====
# INSERT 1
=head1 OPTIONS
L<"--dry-run"> and L<"--execute"> are mutually exclusive.
This tool accepts additional command-line arguments. Refer to the
L<"SYNOPSIS"> and usage information for details.
=over
=item --alter
type: string
The schema modification, without the ALTER TABLE keywords. You can perform
multiple modifications to the table by specifying them with commas. Please refer
to the MySQL manual for the syntax of ALTER TABLE.
The following limitations apply which, if attempted, will cause the tool
to fail in unpredictable ways:
=over
=item *
In almost all cases a PRIMARY KEY or UNIQUE INDEX needs to be present in the table.
This is necessary because the tool creates a DELETE trigger to keep the new table
updated while the process is running.
A notable exception is when a PRIMARY KEY or UNIQUE INDEX is being created from
B as part of the ALTER clause; in that case it will use these
column(s) for the DELETE trigger.
=item *
The C clause cannot be used to rename the table.
=item *
Columns cannot be renamed by dropping and re-adding with the new name.
The tool will not copy the original column's data to the new column.
=item *
If you add a column without a default value and make it NOT NULL, the tool
will fail, as it will not try to guess a default value for you; You must
specify the default.
=item *
C requires specifying C<_constraint_name>
rather than the real C. Due to a limitation in MySQL,
pt-online-schema-change adds a leading underscore to foreign key constraint
names when creating the new table. For example, to drop this constraint:
CONSTRAINT `fk_foo` FOREIGN KEY (`foo_id`) REFERENCES `bar` (`foo_id`)
You must specify C<--alter "DROP FOREIGN KEY _fk_foo">.
=item *
The tool does not use C with MySQL 5.0 because it can
cause a slave error which breaks replication:
Query caused different errors on master and slave. Error on master:
'Deadlock found when trying to get lock; try restarting transaction' (1213),
Error on slave: 'no error' (0). Default database: 'pt_osc'.
Query: 'INSERT INTO pt_osc.t (id, c) VALUES ('730', 'new row')'
The error happens when converting a MyISAM table to InnoDB because MyISAM
is non-transactional but InnoDB is transactional. MySQL 5.1 and newer
handle this case correctly, but testing reproduces the error 5% of the time
with MySQL 5.0.
This is a MySQL bug, similar to L,
but there is no fix or workaround in MySQL 5.0. Without C,
tests pass 100% of the time, so the risk of data loss or breaking replication
should be negligible.
B
=back
=item --alter-foreign-keys-method
type: string
How to modify foreign keys so they reference the new table. Foreign keys that
reference the table to be altered must be treated specially to ensure that they
continue to reference the correct table. When the tool renames the original
table to let the new one take its place, the foreign keys "follow" the renamed
table, and must be changed to reference the new table instead.
The tool supports two techniques to achieve this. It automatically finds "child
tables" that reference the table to be altered.
=over
=item auto
Automatically determine which method is best. The tool uses
C if possible (see the description of that method for
details), and if not, then it uses C.
=item rebuild_constraints
This method uses C to drop and re-add foreign key constraints that
reference the new table. This is the preferred technique, unless one or more of
the "child" tables is so large that the C would take too long. The tool
determines that by comparing the number of rows in the child table to the rate
at which the tool is able to copy rows from the old table to the new table. If
the tool estimates that the child table can be altered in less time than the
L<"--chunk-time">, then it will use this technique. For purposes of estimating
the time required to alter the child table, the tool multiplies the row-copying
rate by L<"--chunk-size-limit">, because MySQL's C is typically
much faster than the external process of copying rows.
Due to a limitation in MySQL, foreign keys will not have the same names after
the ALTER that they did prior to it. The tool has to rename the foreign key
when it redefines it, which adds a leading underscore to the name. In some
cases, MySQL also automatically renames indexes required for the foreign key.
=item drop_swap
Disable foreign key checks (FOREIGN_KEY_CHECKS=0), then drop the original table
before renaming the new table into its place. This is different from the normal
method of swapping the old and new table, which uses an atomic C that is
undetectable to client applications.
This method is faster and does not block, but it is riskier for two reasons.
First, for a short time between dropping the original table and renaming the
temporary table, the table to be altered simply does not exist, and queries
against it will result in an error. Secondly, if there is an error and the new
table cannot be renamed into the place of the old one, then it is too late to
abort, because the old table is gone permanently.
This method forces C<--no-swap-tables> and C<--no-drop-old-table>.
=item none
This method is like C without the "swap". Any foreign keys that
referenced the original table will now reference a nonexistent table. This will
typically cause foreign key violations that are visible in C