percona-toolkit-2.2.20/0000775000175000017500000000000013021632517014577 5ustar vagrantvagrantpercona-toolkit-2.2.20/INSTALL0000664000175000017500000000276713021632517015644 0ustar vagrantvagrantInstalling 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.20/docs/0000775000175000017500000000000013021632517015527 5ustar vagrantvagrantpercona-toolkit-2.2.20/docs/percona-toolkit.pod0000664000175000017500000003630613021632517021355 0ustar vagrantvagrant=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) 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 derived from Maatkit and Aspersa, two of the best-known toolkits for MySQL server administration. It is developed and supported by Percona. For more information and other free, open-source software developed by Percona, visit L. =head1 TOOLS This release of Percona Toolkit includes the following tools: =over =item pt-align Align output from other tools to columns. =item pt-archiver Archive rows from a MySQL table into another table or a file. =item pt-config-diff Diff MySQL configuration files and server variables. =item pt-deadlock-logger Log MySQL deadlocks. =item pt-diskstats An interactive I/O monitoring tool for GNU/Linux. =item pt-duplicate-key-checker Find duplicate indexes and foreign keys on MySQL tables. =item pt-fifo-split Split files and pipe lines to a fifo without really splitting. =item pt-find Find MySQL tables and execute actions, like GNU find. =item pt-fingerprint Convert queries into fingerprints. =item pt-fk-error-logger Log MySQL foreign key errors. =item pt-heartbeat Monitor MySQL replication delay. =item pt-index-usage Read queries from a log and analyze how they use indexes. =item pt-ioprofile Watch process IO and print a table of file and I/O activity. =item pt-kill Kill MySQL queries that match certain criteria. =item pt-mext Look at many samples of MySQL C 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. =head1 SPECIAL OPTION TYPES Tool options use standard types (C, 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-2016 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.20 released 2016-12-06 =cut percona-toolkit-2.2.20/COPYING0000664000175000017500000004325413021632517015642 0ustar vagrantvagrant 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.20/lib/0000775000175000017500000000000013021632517015345 5ustar vagrantvagrantpercona-toolkit-2.2.20/README0000664000175000017500000000236113021632517015461 0ustar vagrantvagrant#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/](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/](http://www.percona.com/software/percona-toolkit/). percona-toolkit-2.2.20/Changelog0000664000175000017500000012246413021632517016422 0ustar vagrantvagrantChangelog for Percona Toolkit v2.2.20 released 2016-12-06 v2.2.20 released 2016-12-09 * Fixed bug 1362942: pt-slave-restart fails on MariaDB 10.0.13 (gtid_mode confusion) * Fixed bug 1566556: pt-show-grants fails against MariaDB10+ * Feature 1604834: pt-query-digest numbers in table or column names converted to question marks (--preserve-embedded-numbers) * Fixed bug 1613915: pt-online-schema-change misses data. Fixed sort order for ENUM fields * Fixed bug 1625005: pt-online-schema-change doesn't apply underscores to foreign keys individually * Fixed bug 1634900: pt-upgrade fails with SELECT INTO * Fixed bug 1635734: pt-slave-restart --config does not recognize = as separator * Feature 1636068: Added pause to NibbleIterator * Feature 1638293: --data-dir parameter in order to create the table on a different partition * Feature 1639052: with pt-table-checksum automatically exclude checking schemas named percona, percona_schema * Feature 1642364: pt-online-schema-change Added --remove-data-dir feature * Feature 1643914: Fixed several typos in the doc (Thanks Dario Minnucci) * Feature 1643940: Add Transparent huge pages info to pt-summary * Feature 1643941: Add Memory management library to pt-mysql-summary v2.2.19 released 2016-08-15 * Feature 1610385: Recheck the list of slaves while OSC runs (Thanks DaniĆ«l van Eeden & Mikhail Izioumtchenko) * Fixed bug 1221372: pt-osc should error if server is a slave in row based replication * Fixed bug 1485195: pt-table-checksum should force replica table charset to utf8 Edit (Thanks Jaime Crespo) * Fixed bug 1517155: Added --create-table-engine param to pt-heartbeat * Fixed bug 1581752: SlowLogParser is able to handle dates in RFC339 format for MySQL 5.7 (Thanks Nickolay Ihalainen) * Fixed bug 1592166: pt-kill leaks memory each time it kills a query * Fixed bug 1592608: Large BLOB/TEXT/BINARY Produces NULL Checksum (Thanks Jervin Real) * Fixed bug 1593265: Fixed pt-archiver deletes wrong rows #103 (Thanks Tibor Korocz & David Ducos) * Fixed bug 1595678: Added --slave-user and --slave-password to pt-online-schema-change & pt-table-sync * Fixed bug 1610386: Handle GTID ranges where the left-side integer is larger than 9 (Thanks @sodabrew) * Fixed bug 1610387: Remove extra word 'default' from the --verbose help (Thanks @sodabrew) * Fixed bug 1610388: add enum column type to is_char check so that values are properly quoted (Thanks Daniel Kinon) v2.2.18 released 2016-06-24 * Feature 1537416 : pt-stalk now sorts the output of transactions by id * Feature 1553340 : Added "Shared" memory info to pt-summary * Feature PT-24 : Added the --no-vertical-format option for pt-query-digest, allowing compatibility with non-standard MySQL clients that don't support the \G directive at the end of a statement * Fixed bug 1402776: Fixed error when parsing tcpdump capture with pt-query-digest * Fixed bug 1521880: Improved pt-online-schema-change plugin documentation * Fixed bug 1547225: Clarified the description of the --attribute-value-limit option for pt-query-digest * Fixed bug 1569564: Fixed all PERL-based tools to return a zero exit status when run with the --version option * Fixed bug 1576036: Fixed error that sometimes prevented to choose the primary key as index, when using the -where option for pt-table-checksum * Fixed bug 1585412: Fixed the inability of pt-query-digest to parse the general log generated by MySQL (and Percona Server) 5.7 instance * Fixed bug PT-36 : Clarified the description of the --verbose option for pt-slave-restart v2.2.17 released 2016-03-07 * Feature : General compatibility with MySQL 5.7 tools, docs and test suite * Fixed bug 1529411: pt-mysql-summary displays incorrect info about Fast Server Restarts for Percona Server 5.6 * Fixed bug 1506748: pt-online-schema-change cannot set sql_mode using --set-vars * Fixed bug 1336734: pt-online-schema-change added --null-to-non-null option to allow NULLable columns to be converted to NOT NULL * Fixed bug 1498128: pt-online-schema-change doesn't apply underscores to foreign keys individually * Fixed bug 1523685: pt-online-schema Invalid recursion method: t=dsns * Fixed bug 1526105: pt-online-schema-change fails when using --no-drop-old-table after 10 times * Fixed bug 1536305: pt-query-digest : Redundant argument in sprintf * Fixed bug PT-27 : pt-query-digest doc bug with --since and too many colons * Fixed bug PT-28 : pt-query-digest: Make documentation of --attribute-value-limit option more clear * Fixed bug 1435370: pt-show-grants fails against MySQL-5.7.6 * Fixed bug 1523730: pt-show-grants doesn't sort column-level privileges * Fixed bug 1362942: pt-slave-restart fails on MariaDB 10.0.13 (gtid_mode confusion) * Fixed bug PT-30 : pt-stalk: new var binlog_error_action causes bug in collect module * Fixed bug 1389041: pt-table-checksum has high likelyhood to skip a table when row count is around chunk-size * chunk-size-limit * Fixed bug 1480719: pt-table-checksum redundant argument in printf 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.20/Makefile.PL0000664000175000017500000000074413021632517016556 0ustar vagrantvagrantuse ExtUtils::MakeMaker; WriteMakefile( NAME => 'percona-toolkit', VERSION => '2.2.20', EXE_FILES => [ ], MAN1PODS => { 'docs/percona-toolkit.pod' => 'blib/man1/percona-toolkit.1p', map { (my $name = $_) =~ s/^bin.//; $_ => "blib/man1/$name.1p"; } }, MAN3PODS => {}, # man(3) pages are for C libs PREREQ_PM => { DBI => 1.46, DBD::mysql => 3.0000_0, }, ); percona-toolkit-2.2.20/CONTRIBUTE.md0000664000175000017500000001543713021632517016611 0ustar vagrantvagrant#Contributing guide ##How Can I Contribute? ##Reporting Bugs Before creating bug reports, please check this list as you might find out that you don't need to create one. When you create a bug report, please include as many details as possible. You can use this template to structure the information. ###Before Submitting A Bug Report - Ensure you have carefully read the documentation. Percona Toolkit is a mature project with many settings that covers a wide range options. - Search for existing bugs in Launchpad to see if the problem has already been reported. If it has, add a comment to the existing issue instead of opening a new one. ###How Do I Submit A (Good) Bug Report? - Explain the problem and include additional details to help others reproduce the problem: - Use a clear and descriptive title for the issue to identify the problem. - Describe the exact steps which reproduce the problem, including as many details as possible. Provide examples of the command you used and include context information like language, OS and database versions. Describe the obtained results and the expected results and, if it is possible, provide examples. ##Submiting fixes ###Create an Issue If you find a bug, the first step is to create an issue. Whatever the problem is, youā€™re likely not the only one experiencing it. Others will find your issue helpful, and other developers might help you find the cause and discuss the best solution for it. ####Tips for creating an issue - Check if there are any existing issues for your problem. By doing this, we can avoid duplicating efforts, since the issue might have been already reported and if not, you might find useful information on older issues related to the same problem. - Be clear about what your problem is: which program were you using, what was the expected result and what is the result you are getting. Detail how someone else can reproduce the problem, including examples. - Include system details like language version, OS, database details or special configurations, etc. - Paste the error output or logs in your issue or in a Gist. ###Pull Requests If you fixed a bug or added a new feature ā€“ awesome! Open a pull request with the code! Be sure youā€™ve read any documents on contributing, understand the license and have signed a Contributor Licence Agreement (CLA) if required. Once youā€™ve submitted a pull request, the maintainers can compare your branch to the existing one and decide whether or not to incorporate (merge) your changes. ###Tips for creating a pull request - Fork the repository and clone it locally. Connect your local to the original ā€˜upstreamā€™ repository by adding it as a remote. Pull in changes from ā€˜upstreamā€™ often so that you stay up to date so that when you submit your pull request, merge conflicts will be less likely. - Create a branch for your code. Usually it is a good practice to name the branch after the issue ID, like issue-12345. - Be clear about the problem you fixed or the feature you added. Include explanations and code references to help the maintainers understand what you did. - Add useful comments to the code to help others understand it. - Write tests. This is an important step. Run your changes against existing tests and create new ones when needed. Whether tests exist or not, make sure your changes donā€™t break the existing project. - Contribute in the style of the project to the best of your abilities. This may mean using indents, semicolons, or comments differently than you would in your own repository, but makes it easier for the maintainer to merge, others to understand and maintain in the future. - Keep your changes as small as possible and solve only what's reported in the issue. Mixing fixes might be confusing to others and makes testing harder. - Be as explicit as possible. Avoid using special/internal language variables like $_. Use a variable name that clearly represents the value it holds. - Write good commit messages. A comment like 'Misc bugfixes' or 'More code added' does not help to understand what's the change about. ###Open Pull Requests Once youā€™ve opened a pull request, a discussion will start around your proposed changes. Other contributors and users may chime in, but ultimately the decision is made by the maintainers. You may be asked to make some changes to your pull request, if so, add more commits to your branch and push them ā€“ theyā€™ll automatically go into the existing pull request. #Licensing Along with the pull request, include a message indicating that the submited code is your own creation and it can be distributed under the BSD licence. #Setting up the development environment ####Setting up the source code To start, fork the Percona Toolkit repo to be able to submit pull requests and clone it locally: ``` mkdir ${HOME}/perldev git clone https://github.com//percona-toolkit.git ${HOME}/perldev/percona-toolkit ``` For testing, we are going to need to have MySQL with slaves. For that, we already have scripts in the sandbox directory but first we need to download MySQL binaries. Please download the Linux Generic tar file for your distrubution from [https://www.percona.com/downloads/Percona-Server-5.6/](https://www.percona.com/downloads/Percona-Server-5.6/). ###Set up MySQL sandbox In this example, we are going to download Percona Server 5.6.32. Since I am using Ubuntu, according to the documentation [here](https://www.percona.com/doc/percona-server/5.6/installation.html#installing-percona-server-from-a-binary-tarball), I am going to need this tar file: [Percona-Server-5.6.32-rel78.1-Linux.x86_64.ssl100.tar.gz](https://www.percona.com/downloads/Percona-Server-5.6/Percona-Server-5.6.32-78.1/binary/tarball/Percona-Server-5.6.32-rel78.1-Linux.x86_64.ssl100.tar.gz). ``` mkdir -p ${HOME}/mysql/percona-server-5.6.32 ``` ``` wget https://www.percona.com/downloads/Percona-Server-5.6/Percona-Server-5.6.32-78.1/binary/tarball/Percona-Server-5.6.32-rel78.1-Linux.x86_64.ssl100.tar.gz ``` ``` tar xvzf Percona-Server-5.6.32-rel78.1-Linux.x86_64.ssl100.tar.gz --strip 1 -C ${HOME}/mysql/percona-server-6.6.32 ``` ###Set up environment variables: We need these environment variables to start the MySQL sandbox and to run the tests. Probably it is a good idea to add them to your `.bashrc` file. ``` export PERL5LIB=${HOME}/perldev/percona-toolkit/lib export PERCONA_TOOLKIT_SANDBOX=${HOME}/mysql/percona-server-5.6.32 ``` ###Starting the sandbox ``` cd ${HOME}/perldev/percona-toolkit ``` ``` sandbox/test-env start ``` To stop the MySQL sandbox: `sandbox/test-env stop` ###Running tests ``` cd ${HOME}/perldev/percona-toolkit ``` Run all tests for a particular program (pt-stalk in this example): ``` prove -v t/pt-stalk/ ``` or run a specific test: ``` prove -v t/pt-stalk/option_sanity.t ``` percona-toolkit-2.2.20/bin/0000775000175000017500000000000013021632517015347 5ustar vagrantvagrantpercona-toolkit-2.2.20/bin/pt-variable-advisor0000775000175000017500000053157413021632517021167 0ustar vagrantvagrant#!/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 OptionParser Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo DSNParser VersionParser Daemon PodParser TextResultSetParser Advisor AdvisorRules VariableAdvisorRules 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.19'; 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 # ########################################################################### # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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; 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 = '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"; } $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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # PodParser 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/PodParser.pm # t/lib/PodParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package PodParser; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; my %parse_items_from = ( 'OPTIONS' => 1, 'DSN OPTIONS' => 1, 'RULES' => 1, ); my %item_pattern_for = ( 'OPTIONS' => qr/--(.*)/, 'DSN OPTIONS' => qr/\* (.)/, 'RULES' => qr/(.*)/, ); my %section_has_rules = ( 'OPTIONS' => 1, 'DSN OPTIONS' => 0, 'RULES' => 0, ); sub new { my ( $class, %args ) = @_; my $self = { current_section => '', current_item => '', items => {}, # keyed off SECTION magic => {}, # keyed off SECTION->magic ident (without MAGIC_) magic_ident => '', # set when next para is a magic para }; return bless $self, $class; } sub get_items { my ( $self, $section ) = @_; return $section ? $self->{items}->{$section} : $self->{items}; } sub get_magic { my ( $self, $section ) = @_; return $section ? $self->{magic}->{$section} : $self->{magic}; } sub parse_from_file { my ( $self, $file ) = @_; return unless $file; PTDEBUG && _d('Parsing POD in', $file); open my $fh, "<", $file or die "Cannot open $file: $OS_ERROR"; local $INPUT_RECORD_SEPARATOR = ''; # read paragraphs my $para; 1 while defined($para = <$fh>) && $para !~ m/^=pod/; die "$file does not contain =pod" unless $para; while ( defined($para = <$fh>) && $para !~ m/^=cut/ ) { if ( $para =~ m/^=(head|item|over|back)/ ) { my ($cmd, $name) = $para =~ m/^=(\w+)(?:\s+(.+))?/; $name ||= ''; PTDEBUG && _d('cmd:', $cmd, 'name:', $name); $self->command($cmd, $name); } elsif ( $parse_items_from{$self->{current_section}} ) { $self->textblock($para); } } close $fh; } sub command { my ( $self, $cmd, $name ) = @_; $name =~ s/\s+\Z//m; # Remove \n and blank line after name. if ( $cmd eq 'head1' ) { PTDEBUG && _d('In section', $name); $self->{current_section} = $name; } elsif ( $cmd eq 'over' ) { if ( $parse_items_from{$name} ) { PTDEBUG && _d('Start items in', $self->{current_section}); $self->{items}->{$self->{current_section}} = {}; } } elsif ( $cmd eq 'item' && $parse_items_from{$self->{current_section}} ) { my $pat = $item_pattern_for{ $self->{current_section} }; my ($item) = $name =~ m/$pat/; if ( $item ) { PTDEBUG && _d($self->{current_section}, 'item:', $item); $self->{items}->{ $self->{current_section} }->{$item} = { desc => '', # every item should have a desc }; $self->{current_item} = $item; } else { warn "Item $name does not match $pat"; } } elsif ( $cmd eq 'back' ) { if ( $parse_items_from{$self->{current_section}} ) { PTDEBUG && _d('End items in', $self->{current_section}); } } else { $self->{current_section} = ''; } return; } sub textblock { my ( $self, $para ) = @_; return unless $self->{current_section} && $self->{current_item}; my $section = $self->{current_section}; my $item = $self->{items}->{$section}->{ $self->{current_item} }; $para =~ s/\s+\Z//; if ( $para =~ m/^[a-z]\w+[:;] / ) { PTDEBUG && _d('Item attributes:', $para); map { my ($attrib, $val) = split(/: /, $_); $item->{$attrib} = defined $val ? $val : 1; } split(/; /, $para); } else { if ( $self->{magic_ident} ) { my ($leading_space) = $para =~ m/^(\s+)/; my $indent = length($leading_space || ''); if ( $indent ) { $para =~ s/^\s{$indent}//mg; $para =~ s/\s+$//; PTDEBUG && _d("MAGIC", $self->{magic_ident}, "para:", $para); $self->{magic}->{$self->{current_section}}->{$self->{magic_ident}} = $para; } else { PTDEBUG && _d("MAGIC", $self->{magic_ident}, "para is not indented; treating as normal para"); } $self->{magic_ident} = ''; # must unset this! } PTDEBUG && _d('Item desc:', substr($para, 0, 40), length($para) > 40 ? '...' : ''); $para =~ s/\n+/ /g; $item->{desc} .= $para; if ( $para =~ m/MAGIC_(\w+)/ ) { $self->{magic_ident} = $1; # XXX PTDEBUG && _d("MAGIC", $self->{magic_ident}, "follows"); } } return; } sub verbatim { my ( $self, $para ) = @_; 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 PodParser 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 # ########################################################################### # ########################################################################### # Advisor 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/Advisor.pm # t/lib/Advisor.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package Advisor; 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(match_type) ) { die "I need a $arg argument" unless $args{$arg}; } my $self = { %args, rules => [], # Rules from all advisor modules. rule_index_for => {}, # Maps rules by ID to their array index in $rules. rule_info => {}, # ID, severity, description, etc. for each rule. }; return bless $self, $class; } sub load_rules { my ( $self, $advisor ) = @_; return unless $advisor; PTDEBUG && _d('Loading rules from', ref $advisor); my $i = scalar @{$self->{rules}}; RULE: foreach my $rule ( $advisor->get_rules() ) { my $id = $rule->{id}; if ( $self->{ignore_rules}->{"$id"} ) { PTDEBUG && _d("Ignoring rule", $id); next RULE; } die "Rule $id already exists and cannot be redefined" if defined $self->{rule_index_for}->{$id}; push @{$self->{rules}}, $rule; $self->{rule_index_for}->{$id} = $i++; } return; } sub load_rule_info { my ( $self, $advisor ) = @_; return unless $advisor; PTDEBUG && _d('Loading rule info from', ref $advisor); my $rules = $self->{rules}; foreach my $rule ( @$rules ) { my $id = $rule->{id}; if ( $self->{ignore_rules}->{"$id"} ) { die "Rule $id was loaded but should be ignored"; } my $rule_info = $advisor->get_rule_info($id); next unless $rule_info; die "Info for rule $id already exists and cannot be redefined" if $self->{rule_info}->{$id}; $self->{rule_info}->{$id} = $rule_info; } return; } sub run_rules { my ( $self, %args ) = @_; my @matched_rules; my @matched_pos; my $rules = $self->{rules}; my $match_type = lc $self->{match_type}; foreach my $rule ( @$rules ) { eval { my $match = $rule->{code}->(%args); if ( $match_type eq 'pos' ) { if ( defined $match ) { PTDEBUG && _d('Matches rule', $rule->{id}, 'near pos', $match); push @matched_rules, $rule->{id}; push @matched_pos, $match; } } elsif ( $match_type eq 'bool' ) { if ( $match ) { PTDEBUG && _d("Matches rule", $rule->{id}); push @matched_rules, $rule->{id}; } } }; if ( $EVAL_ERROR ) { warn "Code for rule $rule->{id} caused an error: $EVAL_ERROR"; } } return \@matched_rules, \@matched_pos; }; sub get_rule_info { my ( $self, $id ) = @_; return unless $id; return $self->{rule_info}->{$id}; } 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 Advisor package # ########################################################################### # ########################################################################### # AdvisorRules 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/AdvisorRules.pm # t/lib/AdvisorRules.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package AdvisorRules; 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(PodParser) ) { die "I need a $arg argument" unless $args{$arg}; } my $self = { %args, rules => [], rule_info => {}, }; return bless $self, $class; } sub load_rule_info { my ( $self, %args ) = @_; foreach my $arg ( qw(file section ) ) { die "I need a $arg argument" unless $args{$arg}; } my $rules = $args{rules} || $self->{rules}; my $p = $self->{PodParser}; $p->parse_from_file($args{file}); my $rule_items = $p->get_items($args{section}); my %seen; foreach my $rule_id ( keys %$rule_items ) { my $rule = $rule_items->{$rule_id}; die "Rule $rule_id has no description" unless $rule->{desc}; die "Rule $rule_id has no severity" unless $rule->{severity}; die "Rule $rule_id is already defined" if exists $self->{rule_info}->{$rule_id}; $self->{rule_info}->{$rule_id} = { id => $rule_id, severity => $rule->{severity}, description => $rule->{desc}, }; } foreach my $rule ( @$rules ) { die "There is no info for rule $rule->{id} in $args{file}" unless $self->{rule_info}->{ $rule->{id} }; } return; } sub get_rule_info { my ( $self, $id ) = @_; return unless $id; return $self->{rule_info}->{$id}; } sub _reset_rule_info { my ( $self ) = @_; $self->{rule_info} = {}; 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 AdvisorRules package # ########################################################################### # ########################################################################### # VariableAdvisorRules 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/VariableAdvisorRules.pm # t/lib/VariableAdvisorRules.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package VariableAdvisorRules; use base 'AdvisorRules'; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; sub new { my ( $class, %args ) = @_; my $self = $class->SUPER::new(%args); @{$self->{rules}} = $self->get_rules(); PTDEBUG && _d(scalar @{$self->{rules}}, "rules"); return $self; } sub get_rules { return { id => 'auto_increment', code => sub { my ( %args ) = @_; my $vars = $args{variables}; return unless defined $vars->{auto_increment_increment} && defined $vars->{auto_increment_offset}; return $vars->{auto_increment_increment} != 1 || $vars->{auto_increment_offset} != 1 ? 1 : 0; }, }, { id => 'concurrent_insert', code => sub { my ( %args ) = @_; if ( $args{variables}->{concurrent_insert} && $args{variables}->{concurrent_insert} =~ m/[^\d]/ ) { return $args{variables}->{concurrent_insert} eq 'ALWAYS' ? 1 : 0; } return _var_gt($args{variables}->{concurrent_insert}, 1); }, }, { id => 'connect_timeout', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{connect_timeout}, 10); }, }, { id => 'debug', code => sub { my ( %args ) = @_; return $args{variables}->{debug} ? 1 : 0; }, }, { id => 'delay_key_write', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{delay_key_write}, "ON"); }, }, { id => 'flush', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{flush}, "ON"); }, }, { id => 'flush_time', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{flush_time}, 0); }, }, { id => 'have_bdb', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{have_bdb}, 'YES'); }, }, { id => 'init_connect', code => sub { my ( %args ) = @_; return $args{variables}->{init_connect} ? 1 : 0; }, }, { id => 'init_file', code => sub { my ( %args ) = @_; return $args{variables}->{init_file} ? 1 : 0; }, }, { id => 'init_slave', code => sub { my ( %args ) = @_; return $args{variables}->{init_slave} ? 1 : 0; }, }, { id => 'innodb_additional_mem_pool_size', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{innodb_additional_mem_pool_size}, 20 * 1_048_576); # 20M }, }, { id => 'innodb_buffer_pool_size', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{innodb_buffer_pool_size}, 10 * 1_048_576); # 10M }, }, { id => 'innodb_checksums', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{innodb_checksums}, "ON"); }, }, { id => 'innodb_doublewrite', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{innodb_doublewrite}, "ON"); }, }, { id => 'innodb_fast_shutdown', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{innodb_fast_shutdown}, 1); }, }, { id => 'innodb_flush_log_at_trx_commit-1', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{innodb_flush_log_at_trx_commit}, 1); }, }, { id => 'innodb_flush_log_at_trx_commit-2', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{innodb_flush_log_at_trx_commit}, 0); }, }, { id => 'innodb_force_recovery', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{innodb_force_recovery}, 0); }, }, { id => 'innodb_lock_wait_timeout', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{innodb_lock_wait_timeout}, 50); }, }, { id => 'innodb_log_buffer_size', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{innodb_log_buffer_size}, 16 * 1_048_576); # 16M }, }, { id => 'innodb_log_file_size', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{innodb_log_file_size}, 5 * 1_048_576); # 5M }, }, { id => 'innodb_max_dirty_pages_pct', code => sub { my ( %args ) = @_; my $mysql_version = $args{mysql_version}; return _var_lt($args{variables}->{innodb_max_dirty_pages_pct}, ($mysql_version < '5.5' ? 90 : 75)); }, }, { id => 'key_buffer_size', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{key_buffer_size}, 8 * 1_048_576); # 8M }, }, { id => 'large_pages', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{large_pages}, "ON"); }, }, { id => 'locked_in_memory', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{locked_in_memory}, "ON"); }, }, { id => 'log_warnings-1', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{log_warnings}, 0); }, }, { id => 'log_warnings-2', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{log_warnings}, 1); }, }, { id => 'low_priority_updates', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{low_priority_updates}, "ON"); }, }, { id => 'max_binlog_size', code => sub { my ( %args ) = @_; return _var_lt($args{variables}->{max_binlog_size}, 1 * 1_073_741_824); # 1G }, }, { id => 'max_connect_errors', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{max_connect_errors}, 10); }, }, { id => 'max_connections', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{max_connections}, 1_000); }, }, { id => 'myisam_repair_threads', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{myisam_repair_threads}, 1); }, }, { id => 'old_passwords', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{old_passwords}, "ON"); }, }, { id => 'optimizer_prune_level', code => sub { my ( %args ) = @_; return _var_lt($args{variables}->{optimizer_prune_level}, 1); }, }, { id => 'port', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{port}, 3306); }, }, { id => 'query_cache_size-1', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{query_cache_size}, 128 * 1_048_576); # 128M }, }, { id => 'query_cache_size-2', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{query_cache_size}, 512 * 1_048_576); # 512M }, }, { id => 'read_buffer_size-1', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{read_buffer_size}, 131_072); }, }, { id => 'read_buffer_size-2', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{read_buffer_size}, 8 * 1_048_576); # 8M }, }, { id => 'read_rnd_buffer_size-1', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{read_rnd_buffer_size}, 262_144); }, }, { id => 'read_rnd_buffer_size-2', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{read_rnd_buffer_size}, 4 * 1_048_576); # 4M }, }, { id => 'relay_log_space_limit', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{relay_log_space_limit}, 0); }, }, { id => 'slave_net_timeout', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{slave_net_timeout}, 60); }, }, { id => 'slave_skip_errors', code => sub { my ( %args ) = @_; return $args{variables}->{slave_skip_errors} && $args{variables}->{slave_skip_errors} ne 'OFF' ? 1 : 0; }, }, { id => 'sort_buffer_size-1', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{sort_buffer_size}, 2_097_144); }, }, { id => 'sort_buffer_size-2', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{sort_buffer_size}, 4 * 1_048_576); # 4M }, }, { id => 'sql_notes', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{sql_notes}, "OFF"); }, }, { id => 'sync_frm', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{sync_frm}, "ON"); }, }, { id => 'tx_isolation-1', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{tx_isolation}, "REPEATABLE-READ"); }, }, { id => 'tx_isolation-2', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{tx_isolation}, "REPEATABLE-READ") && _var_sneq($args{variables}->{tx_isolation}, "READ-COMMITTED") ? 1 : 0; }, }, { id => 'expire_logs_days', code => sub { my ( %args ) = @_; return _var_eq($args{variables}->{expire_logs_days}, 0) && _var_seq($args{variables}->{log_bin}, "ON"); }, }, { id => 'innodb_file_io_threads', code => sub { my ( %args ) = @_; return _var_neq($args{variables}->{innodb_file_io_threads}, 4) && $OSNAME ne 'MSWin32' ? 1 : 0; }, }, { id => 'innodb_data_file_path', code => sub { my ( %args ) = @_; return ($args{variables}->{innodb_data_file_path} || '') =~ m/autoextend/ ? 1 : 0; }, }, { id => 'innodb_flush_method', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{innodb_flush_method}, 'O_DIRECT') && $OSNAME ne 'MSWin32' ? 1 : 0; }, }, { id => 'innodb_locks_unsafe_for_binlog', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{innodb_locks_unsafe_for_binlog}, "ON") && _var_seq($args{variables}->{log_bin}, "ON"); }, }, { id => 'innodb_support_xa', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{innodb_support_xa}, "ON") && _var_seq($args{variables}->{log_bin}, "ON"); }, }, { id => 'log_bin', code => sub { my ( %args ) = @_; return _var_sneq($args{variables}->{log_bin}, "ON"); }, }, { id => 'log_output', code => sub { my ( %args ) = @_; return ($args{variables}->{log_output} || '') =~ m/TABLE/i ? 1 : 0; }, }, { id => 'max_relay_log_size', code => sub { my ( %args ) = @_; return _var_gt($args{variables}->{max_relay_log_size}, 0) && _var_lt($args{variables}->{max_relay_log_size}, 1 * 1_073_741_824) ? 1 : 0; }, }, { id => 'myisam_recover_options', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{myisam_recover_options}, "OFF") || _var_seq($args{variables}->{myisam_recover_options}, "DEFAULT") ? 1 : 0; }, }, { id => 'storage_engine', code => sub { my ( %args ) = @_; return 0 unless $args{variables}->{storage_engine}; return $args{variables}->{storage_engine} !~ m/InnoDB|MyISAM/i ? 1 : 0; }, }, { id => 'sync_binlog', code => sub { my ( %args ) = @_; return _var_seq($args{variables}->{log_bin}, "ON") && ( _var_eq($args{variables}->{sync_binlog}, 0) || _var_gt($args{variables}->{sync_binlog}, 1)) ? 1 : 0; }, }, { id => 'tmp_table_size', code => sub { my ( %args ) = @_; return ($args{variables}->{tmp_table_size} || 0) > ($args{variables}->{max_heap_table_size} || 0) ? 1 : 0; }, }, { id => 'old mysql version', code => sub { my ( %args ) = @_; my $mysql_version = $args{mysql_version}; return 0 unless $mysql_version; return 1 if ($mysql_version == '3' && $mysql_version < '3.23' ) || ($mysql_version == '4' && $mysql_version < '4.1.20') || ($mysql_version == '5.0' && $mysql_version < '5.0.37') || ($mysql_version == '5.1' && $mysql_version < '5.1.30'); return 0; }, }, { id => 'end-of-life mysql version', code => sub { my ( %args ) = @_; my $mysql_version = $args{mysql_version}; return 0 unless $mysql_version; return $mysql_version < '5.1' ? 1 : 0; # 5.1.x }, }, }; sub _var_gt { my ($var, $val) = @_; return 0 unless defined $var; return $var > $val ? 1 : 0; } sub _var_lt { my ($var, $val) = @_; return 0 unless defined $var; return $var < $val ? 1 : 0; } sub _var_eq { my ($var, $val) = @_; return 0 unless defined $var; return $var == $val ? 1 : 0; } sub _var_neq { my ($var, $val) = @_; return 0 unless defined $var; return _var_eq($var, $val) ? 0 : 1; } sub _var_seq { my ($var, $val) = @_; return 0 unless defined $var; return $var eq $val ? 1 : 0; } sub _var_sneq { my ($var, $val) = @_; return 0 unless defined $var; return _var_seq($var, $val) ? 0 : 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"; } 1; } # ########################################################################### # End VariableAdvisorRules 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_variable_advisor; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); 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()); my $vars_from = $o->get('source-of-variables'); # my $status_from = lc $o->get('source-of-status'); # my $slave_status_from = lc $o->get('source-of-slave-status'); my $need_dbh = $vars_from =~ m/^mysql$/i; # || $status_from eq 'mysql' etc. if ( !$o->get('help') ) { if ( $vars_from =~ m/^mysql$/i && @ARGV == 0 ) { $o->save_error("A DSN must be specified when --source-of-variables=mysql"); } } $o->usage_or_errors(); # ######################################################################### # Check that any files given exit. # ######################################################################### if ( $vars_from !~ m/^mysql|none^/i ) { die "The --source-of-variables file $vars_from does not exist" unless -f $vars_from; } # ######################################################################### # Load rules from POD and plugins. # ######################################################################### my $p = new PodParser(); my $var = new VariableAdvisorRules(PodParser => $p); my $adv = new Advisor( match_type => "bool", ignore_rules => $o->get('ignore-rules'), ); $var->load_rule_info( file => __FILE__, section => 'RULES', ); $adv->load_rules($var); $adv->load_rule_info($var); # TODO: load rules from plugins # ######################################################################### # Make common modules. # ######################################################################### my $trp = new TextResultSetParser(); my %common_modules = ( OptionParser => $o, DSNParser => $dp, TextResultSetParser => $trp, ); # ########################################################################## # Connect to MySQL if any of the input sources is mysql. # ########################################################################## my ($dbh, $dsn); if ( $need_dbh ) { my $dsn_defaults = $dp->parse_options($o); $dsn = $dp->parse(shift @ARGV, $dsn_defaults); if ( $o->get('ask-pass') ) { $dsn->{p} = OptionParser::prompt_noecho("Enter password: "); } $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), {AutoCommit => 1}); $dbh->{FetchHashKeyName} = 'NAME_lc'; PTDEBUG && _d('Connected dbh', $dbh); } # ######################################################################## # Daemonize now that everything is setup and ready to work. # ######################################################################## 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(); } # ######################################################################## # 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 => $dbh, dsn => $dsn } : ()) ], ); } # ######################################################################### # Get the variables and other MySQL info to pass to rules. # ######################################################################### my $vars = get_variables( source => $vars_from, dbh => $dbh, %common_modules, ); my $mysql_version = VersionParser->new($vars->{version}); my $innodb_version = VersionParser->new($dbh)->innodb_version() if $dbh; PTDEBUG && _d("MySQL version", $mysql_version, "InnoDB version", $innodb_version); # ######################################################################### # Run rules, print advice. # ######################################################################### my ($advice) = $adv->run_rules( variables => $vars, mysql_version => $mysql_version, innodb_version => $innodb_version, %common_modules, ); print_advice( advice => $advice, Advisor => $adv, %common_modules, ); return 0; } # ########################################################################## # Subroutines # ########################################################################## # Sub: get_variables # Get SHOW VARIABLES from MySQL or a file. # # Parameters: # %args - Arguments # # Required Arguments: # source - "mysql" or a file name # # Optional Arguments: # dbh - dbh if source=="mysql" # TextResultSetParser - object if source==file # # Returns: # Hashref of SHOW /*40003 GLOBAL*/ VARIABLES values. sub get_variables { my ( %args ) = @_; my @required_args = qw(source); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($source) = @args{@required_args}; my $vars; if ( ($source || '') =~ m/^mysql$/i ) { my $dbh = $args{dbh}; die "I need a dbh argument" unless $dbh; PTDEBUG && _d("Getting variables from dbh", $dbh); my $sql = "SHOW /*40003 GLOBAL*/ VARIABLES"; PTDEBUG && _d($dbh, $sql); map { $vars->{$_->{variable_name}} = $_->{value}; } @{ $dbh->selectall_arrayref($sql, {Slice=>{}}) }; } else { my $trp = $args{TextResultSetParser}; die "I need a TextResultSetParser arg" unless $trp; PTDEBUG && _d("Getting variables from", $source); open my $fh, "<", $source or die "Cannot open $source: $OS_ERROR"; my $contents = do { local $/ = undef; <$fh> }; close $fh; map { $vars->{$_->{Variable_name}} = $_->{Value} } @{ $trp->parse($contents) }; } return $vars; } # Sub: print_advice # Print information about rules that matched. # # Parameters: # %args - Arguments # # Required Arguments: # advice - Arrayref of rule IDs, returned by # Advisor - object # OptionParser - object sub print_advice { my ( %args ) = @_; my @required_args = qw(advice Advisor OptionParser); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($advice, $adv, $o) = @args{@required_args}; my $verbose = $o->get('verbose'); return unless scalar @$advice; foreach my $id ( @$advice ) { my $info = $adv->get_rule_info($id); my @desc = map { $_ .= '.' unless m/[.?]$/; $_; } split(/(?<=[.?])\s{1,2}/, $info->{description} || ''); $desc[1] ||= ""; # Some desc have only 1 sentence. my $desc = $verbose == 1 ? $desc[0] # terse : $verbose == 2 ? "$desc[0] $desc[1]" # fuller : $verbose > 2 ? $info->{description} # complete : ''; # none print "# ", uc $info->{severity}, " $id: $desc\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"; } # ############################################################################ # Run the program. # ############################################################################ if ( !caller ) { exit main(@ARGV); } 1; # Because this is a module as well as a script. # ############################################################################ # Documentation # ############################################################################ =pod =head1 NAME pt-variable-advisor - Analyze MySQL variables and advise on possible problems. =head1 SYNOPSIS Usage: pt-variable-advisor [OPTIONS] [DSN] pt-variable-advisor analyzes variables and advises on possible problems. Get SHOW VARIABLES from localhost: pt-variable-advisor localhost Get SHOW VARIABLES output saved in vars.txt: pt-variable-advisor --source-of-variables vars.txt =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-variable-advisor examines C for bad values and settings according to the L<"RULES"> described below. It reports on variables that match the rules, so you can find bad settings in your MySQL server. At the time of this release, pt-variable-advisor only examples C, but other input sources are planned like C and C. =head1 RULES These are the rules that pt-variable-advisor will apply to SHOW VARIABLES. Each rule has three parts: an ID, a severity, and a description. The rule's ID is a short, unique name for the rule. It usually relates to the variable that the rule examines. If a variable is examined by several rules, then the rules' IDs are numbered like "-1", "-2", "-N". The rule's severity is an indication of how important it is that this rule matched a query. We use NOTE, WARN, and CRIT to denote these levels. The rule's description is a textual, human-readable explanation of what it means when a variable matches this rule. Depending on the verbosity of the report you generate, you will see more of the text in the description. By default, you'll see only the first sentence, which is sort of a terse synopsis of the rule's meaning. At a higher verbosity, you'll see subsequent sentences. =over =item auto_increment severity: note Are you trying to write to more than one server in a dual-master or ring replication configuration? This is potentially very dangerous and in most cases is a serious mistake. Most people's reasons for doing this are actually not valid at all. =item concurrent_insert severity: note Holes (spaces left by deletes) in MyISAM tables might never be reused. =item connect_timeout severity: note A large value of this setting can create a denial of service vulnerability. =item debug severity: crit Servers built with debugging capability should not be used in production because of the large performance impact. =item delay_key_write severity: warn MyISAM index blocks are never flushed until necessary. If there is a server crash, data corruption on MyISAM tables can be much worse than usual. =item flush severity: warn This option might decrease performance greatly. =item flush_time severity: warn This option might decrease performance greatly. =item have_bdb severity: note The BDB engine is deprecated. If you aren't using it, you should disable it with the skip_bdb option. =item init_connect severity: note The init_connect option is enabled on this server. =item init_file severity: note The init_file option is enabled on this server. =item init_slave severity: note The init_slave option is enabled on this server. =item innodb_additional_mem_pool_size severity: warn This variable generally doesn't need to be larger than 20MB. =item innodb_buffer_pool_size severity: warn The InnoDB buffer pool size is unconfigured. In a production environment it should always be configured explicitly, and the default 10MB size is not good. =item innodb_checksums severity: warn InnoDB checksums are disabled. Your data is not protected from hardware corruption or other errors! =item innodb_doublewrite severity: warn InnoDB doublewrite is disabled. Unless you use a filesystem that protects against partial page writes, your data is not safe! =item innodb_fast_shutdown severity: warn InnoDB's shutdown behavior is not the default. This can lead to poor performance, or the need to perform crash recovery upon startup. =item innodb_flush_log_at_trx_commit-1 severity: warn InnoDB is not configured in strictly ACID mode. If there is a crash, some transactions can be lost. =item innodb_flush_log_at_trx_commit-2 severity: warn Setting innodb_flush_log_at_trx_commit to 0 has no performance benefits over setting it to 2, and more types of data loss are possible. If you are trying to change it from 1 for performance reasons, you should set it to 2 instead of 0. =item innodb_force_recovery severity: warn InnoDB is in forced recovery mode! This should be used only temporarily when recovering from data corruption or other bugs, not for normal usage. =item innodb_lock_wait_timeout severity: warn This option has an unusually long value, which can cause system overload if locks are not being released. =item innodb_log_buffer_size severity: warn The InnoDB log buffer size generally should not be set larger than 16MB. If you are doing large BLOB operations, InnoDB is not really a good choice of engines anyway. =item innodb_log_file_size severity: warn The InnoDB log file size is set to its default value, which is not usable on production systems. =item innodb_max_dirty_pages_pct severity: note The innodb_max_dirty_pages_pct is lower than the default. This can cause overly aggressive flushing and add load to the I/O system. =item flush_time severity: warn This setting is likely to cause very bad performance every flush_time seconds. =item key_buffer_size severity: warn The key buffer size is set to its default value, which is not good for most production systems. In a production environment, key_buffer_size should be larger than the default 8MB size. =item large_pages severity: note Large pages are enabled. =item locked_in_memory severity: note The server is locked in memory with --memlock. =item log_warnings-1 severity: note Log_warnings is disabled, so unusual events such as statements unsafe for replication and aborted connections will not be logged to the error log. =item log_warnings-2 severity: note Log_warnings must be set greater than 1 to log unusual events such as aborted connections. =item low_priority_updates severity: note The server is running with non-default lock priority for updates. This could cause update queries to wait unexpectedly for read queries. =item max_binlog_size severity: note The max_binlog_size is smaller than the default of 1GB. =item max_connect_errors severity: note max_connect_errors should probably be set as large as your platform allows. =item max_connections severity: warn If the server ever really has more than a thousand threads running, then the system is likely to spend more time scheduling threads than really doing useful work. This variable's value should be considered in light of your workload. =item myisam_repair_threads severity: note myisam_repair_threads > 1 enables multi-threaded repair, which is relatively untested and is still listed as beta-quality code in the official documentation. =item old_passwords severity: warn Old-style passwords are insecure. They are sent in plain text across the wire. =item optimizer_prune_level severity: warn The optimizer will use an exhaustive search when planning complex queries, which can cause the planning process to take a long time. =item port severity: note The server is listening on a non-default port. =item query_cache_size-1 severity: note The query cache does not scale to large sizes and can cause unstable performance when larger than 128MB, especially on multi-core machines. =item query_cache_size-2 severity: warn The query cache can cause severe performance problems when it is larger than 256MB, especially on multi-core machines. =item read_buffer_size-1 severity: note The read_buffer_size variable should generally be left at its default unless an expert determines it is necessary to change it. =item read_buffer_size-2 severity: warn The read_buffer_size variable should not be larger than 8MB. It should generally be left at its default unless an expert determines it is necessary to change it. Making it larger than 2MB can hurt performance significantly, and can make the server crash, swap to death, or just become extremely unstable. =item read_rnd_buffer_size-1 severity: note The read_rnd_buffer_size variable should generally be left at its default unless an expert determines it is necessary to change it. =item read_rnd_buffer_size-2 severity: warn The read_rnd_buffer_size variable should not be larger than 4M. It should generally be left at its default unless an expert determines it is necessary to change it. =item relay_log_space_limit severity: warn Setting relay_log_space_limit can cause replicas to stop fetching binary logs from their master immediately. This could increase the risk that your data will be lost if the master crashes. If the replicas have encountered a limit on relay log space, then it is possible that the latest transactions exist only on the master and no replica has retrieved them. =item slave_net_timeout severity: warn This variable is set too high. This is too long to wait before noticing that the connection to the master has failed and retrying. This should probably be set to 60 seconds or less. It is also a good idea to use pt-heartbeat to ensure that the connection does not appear to time out when the master is simply idle. =item slave_skip_errors severity: crit You should not set this option. If replication is having errors, you need to find and resolve the cause of that; it is likely that your slave's data is different from the master. You can find out with pt-table-checksum. =item sort_buffer_size-1 severity: note The sort_buffer_size variable should generally be left at its default unless an expert determines it is necessary to change it. =item sort_buffer_size-2 severity: note The sort_buffer_size variable should generally be left at its default unless an expert determines it is necessary to change it. Making it larger than a few MB can hurt performance significantly, and can make the server crash, swap to death, or just become extremely unstable. =item sql_notes severity: note This server is configured not to log Note level warnings to the error log. =item sync_frm severity: warn It is best to set sync_frm so that .frm files are flushed safely to disk in case of a server crash. =item tx_isolation-1 severity: note This server's transaction isolation level is non-default. =item tx_isolation-2 severity: warn Most applications should use the default REPEATABLE-READ transaction isolation level, or in a few cases READ-COMMITTED. =item expire_logs_days severity: warn Binary logs are enabled, but automatic purging is not enabled. If you do not purge binary logs, your disk will fill up. If you delete binary logs externally to MySQL, you will cause unwanted behaviors. Always ask MySQL to purge obsolete logs, never delete them externally. =item innodb_file_io_threads severity: note This option is useless except on Windows. =item innodb_data_file_path severity: note Auto-extending InnoDB files can consume a lot of disk space that is very difficult to reclaim later. Some people prefer to set innodb_file_per_table and allocate a fixed-size file for ibdata1. =item innodb_flush_method severity: note Most production database servers that use InnoDB should set innodb_flush_method to O_DIRECT to avoid double-buffering, unless the I/O system is very low performance. =item innodb_locks_unsafe_for_binlog severity: warn This option makes point-in-time recovery from binary logs, and replication, untrustworthy if statement-based logging is used. =item innodb_support_xa severity: warn MySQL's internal XA transaction support between InnoDB and the binary log is disabled. The binary log might not match InnoDB's state after crash recovery, and replication might drift out of sync due to out-of-order statements in the binary log. =item log_bin severity: warn Binary logging is disabled, so point-in-time recovery and replication are not possible. =item log_output severity: warn Directing log output to tables has a high performance impact. =item max_relay_log_size severity: note A custom max_relay_log_size is defined. =item myisam_recover_options severity: warn myisam_recover_options should be set to some value such as BACKUP,FORCE to ensure that table corruption is noticed. =item storage_engine severity: note The server is using a non-standard storage engine as default. =item sync_binlog severity: warn Binary logging is enabled, but sync_binlog isn't configured so that every transaction is flushed to the binary log for durability. =item tmp_table_size severity: note The effective minimum size of in-memory implicit temporary tables used internally during query execution is min(tmp_table_size, max_heap_table_size), so max_heap_table_size should be at least as large as tmp_table_size. =item old mysql version severity: warn These are the recommended minimum version for each major release: 3.23, 4.1.20, 5.0.37, 5.1.30. =item end-of-life mysql version severity: note Every release older than 5.1 is now officially end-of-life. =back =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. =item --daemonize Fork to the background and detach from the shell. POSIX operating systems only. =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 --ignore-rules type: hash Ignore these rule IDs. Specify a comma-separated list of rule IDs (e.g. LIT.001,RES.002,etc.) to ignore. =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 --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 --source-of-variables type: string; default: mysql Read C from this source. Possible values are "mysql", "none" or a file name. If "mysql" is specified then you must also specify a DSN on the command line. =item --user short form: -u; type: string User for login if not current user. =item --verbose short form: -v; cumulative: yes; default: 1 Increase verbosity of output. At the default level of verbosity, the program prints only the first sentence of each rule's description. At higher levels, the program prints more of the description. =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-variable-advisor ... > 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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2010-2016 Percona LLC and/or its affiliates. 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 pt-variable-advisor 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-kill0000775000175000017500000075031313021632517016662 0ustar vagrantvagrant#!/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 OptionParser Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo DSNParser Daemon Transformers TableParser Processlist TextResultSetParser MasterSlave Quoter QueryRewriter Retry Cxn 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.19'; 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 # ########################################################################### # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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; 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 = '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"; } $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 # ########################################################################### # ########################################################################### # 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 ? '%1$.'.$p.'f%2$s' : '%1$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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # Processlist 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/Processlist.pm # t/lib/Processlist.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package Processlist; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use Time::HiRes qw(time usleep); use List::Util qw(max); use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; use constant PTDEBUG => $ENV{PTDEBUG} || 0; use constant { ID => 0, USER => 1, HOST => 2, DB => 3, COMMAND => 4, TIME => 5, STATE => 6, INFO => 7, START => 8, # Calculated start time of statement ($start - TIME) ETIME => 9, # Exec time of SHOW PROCESSLIST (margin of error in START) FSEEN => 10, # First time ever seen PROFILE => 11, # Profile of individual STATE times }; sub new { my ( $class, %args ) = @_; foreach my $arg ( qw(MasterSlave) ) { die "I need a $arg argument" unless $args{$arg}; } my $self = { %args, polls => 0, last_poll => 0, active_cxn => {}, # keyed off ID event_cache => [], _reasons_for_matching => {}, }; return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(code); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($code) = @args{@required_args}; if ( @{$self->{event_cache}} ) { PTDEBUG && _d("Returning cached event"); return shift @{$self->{event_cache}}; } if ( $self->{interval} && $self->{polls} ) { PTDEBUG && _d("Sleeping between polls"); usleep($self->{interval}); } PTDEBUG && _d("Polling PROCESSLIST"); my ($time, $etime) = @args{qw(time etime)}; my $start = $etime ? 0 : time; # don't need start if etime given my $rows = $code->(); if ( !$rows ) { warn "Processlist callback did not return an arrayref"; return; } $time = time unless $time; $etime = $time - $start unless $etime; $self->{polls}++; PTDEBUG && _d('Rows:', ($rows ? scalar @$rows : 0), 'in', $etime, 'seconds'); my $active_cxn = $self->{active_cxn}; my $curr_cxn = {}; my @new_cxn = (); CURRENTLY_ACTIVE_CXN: foreach my $curr ( @$rows ) { $curr_cxn->{$curr->[ID]} = $curr; my $query_start = $time - ($curr->[TIME] || 0); if ( $active_cxn->{$curr->[ID]} ) { PTDEBUG && _d('Checking existing cxn', $curr->[ID]); my $prev = $active_cxn->{$curr->[ID]}; # previous state of cxn my $new_query = 0; my $fudge = ($curr->[TIME] || 0) =~ m/\D/ ? 0.001 : 1; # micro-t? if ( $prev->[INFO] ) { if ( !$curr->[INFO] || $prev->[INFO] ne $curr->[INFO] ) { PTDEBUG && _d('Info is different; new query'); $new_query = 1; } elsif ( defined $curr->[TIME] && $curr->[TIME] < $prev->[TIME] ) { PTDEBUG && _d('Time is less than previous; new query'); $new_query = 1; } elsif ( $curr->[INFO] && defined $curr->[TIME] && $query_start - $etime - $prev->[START] > $fudge) { my $ms = $self->{MasterSlave}; my $is_repl_thread = $ms->is_replication_thread({ Command => $curr->[COMMAND], User => $curr->[USER], State => $curr->[STATE], Id => $curr->[ID]}); if ( $is_repl_thread ) { PTDEBUG && _d(q{Query has restarted but it's a replication thread, ignoring}); } else { PTDEBUG && _d('Query restarted; new query', $query_start, $etime, $prev->[START], $fudge); $new_query = 1; } } if ( $new_query ) { $self->_update_profile($prev, $curr, $time); push @{$self->{event_cache}}, $self->make_event($prev, $time); } } if ( $curr->[INFO] ) { if ( $prev->[INFO] && !$new_query ) { PTDEBUG && _d("Query on cxn", $curr->[ID], "hasn't changed"); $self->_update_profile($prev, $curr, $time); } else { PTDEBUG && _d('Saving new query, state', $curr->[STATE]); push @new_cxn, [ @{$curr}[0..7], # proc info int($query_start), # START $etime, # ETIME $time, # FSEEN { ($curr->[STATE] || "") => 0 }, # PROFILE ]; } } } else { PTDEBUG && _d('New cxn', $curr->[ID]); if ( $curr->[INFO] && defined $curr->[TIME] ) { PTDEBUG && _d('Saving query of new cxn, state', $curr->[STATE]); push @new_cxn, [ @{$curr}[0..7], # proc info int($query_start), # START $etime, # ETIME $time, # FSEEN { ($curr->[STATE] || "") => 0 }, # PROFILE ]; } } } # CURRENTLY_ACTIVE_CXN PREVIOUSLY_ACTIVE_CXN: foreach my $prev ( values %$active_cxn ) { if ( !$curr_cxn->{$prev->[ID]} ) { PTDEBUG && _d('cxn', $prev->[ID], 'ended'); push @{$self->{event_cache}}, $self->make_event($prev, $time); delete $active_cxn->{$prev->[ID]}; } elsif ( ($curr_cxn->{$prev->[ID]}->[COMMAND] || "") eq 'Sleep' || !$curr_cxn->{$prev->[ID]}->[STATE] || !$curr_cxn->{$prev->[ID]}->[INFO] ) { PTDEBUG && _d('cxn', $prev->[ID], 'became idle'); delete $active_cxn->{$prev->[ID]}; } } map { $active_cxn->{$_->[ID]} = $_; } @new_cxn; $self->{last_poll} = $time; my $event = shift @{$self->{event_cache}}; PTDEBUG && _d(scalar @{$self->{event_cache}}, "events in cache"); return $event; } sub make_event { my ( $self, $row, $time ) = @_; my $observed_time = $time - $row->[FSEEN]; my $Query_time = max($row->[TIME], $observed_time); my $event = { id => $row->[ID], db => $row->[DB], user => $row->[USER], host => $row->[HOST], arg => $row->[INFO], bytes => length($row->[INFO]), ts => Transformers::ts($row->[START] + $row->[TIME]), # Query END time Query_time => $Query_time, Lock_time => $row->[PROFILE]->{Locked} || 0, }; PTDEBUG && _d('Properties of event:', Dumper($event)); return $event; } sub _get_active_cxn { my ( $self ) = @_; PTDEBUG && _d("Active cxn:", Dumper($self->{active_cxn})); return $self->{active_cxn}; } sub _update_profile { my ( $self, $prev, $curr, $time ) = @_; return unless $prev && $curr; my $time_elapsed = $time - $self->{last_poll}; if ( ($prev->[STATE] || "") eq ($curr->[STATE] || "") ) { PTDEBUG && _d("Query is still in", $curr->[STATE], "state"); $prev->[PROFILE]->{$prev->[STATE] || ""} += $time_elapsed; } else { PTDEBUG && _d("Query changed from state", $prev->[STATE], "to", $curr->[STATE]); my $half_time = ($time_elapsed || 0) / 2; $prev->[PROFILE]->{$prev->[STATE] || ""} += $half_time; $prev->[STATE] = $curr->[STATE]; $prev->[PROFILE]->{$curr->[STATE] || ""} = $half_time; } return; } sub find { my ( $self, $proclist, %find_spec ) = @_; PTDEBUG && _d('find specs:', Dumper(\%find_spec)); my $ms = $self->{MasterSlave}; my @matches; $self->{_reasons_for_matching} = undef; QUERY: foreach my $query ( @$proclist ) { PTDEBUG && _d('Checking query', Dumper($query)); my $matched = 0; if ( !$find_spec{replication_threads} && $ms->is_replication_thread($query) ) { PTDEBUG && _d('Skipping replication thread'); next QUERY; } if ( $find_spec{busy_time} && ($query->{Command} || '') eq 'Query' ) { next QUERY unless defined($query->{Time}); if ( $query->{Time} < $find_spec{busy_time} ) { PTDEBUG && _d("Query isn't running long enough"); next QUERY; } my $reason = 'Exceeds busy time'; PTDEBUG && _d($reason); push @{$self->{_reasons_for_matching}->{$query} ||= []}, $reason; $matched++; } if ( $find_spec{idle_time} && ($query->{Command} || '') eq 'Sleep' ) { next QUERY unless defined($query->{Time}); if ( $query->{Time} < $find_spec{idle_time} ) { PTDEBUG && _d("Query isn't idle long enough"); next QUERY; } my $reason = 'Exceeds idle time'; PTDEBUG && _d($reason); push @{$self->{_reasons_for_matching}->{$query} ||= []}, $reason; $matched++; } PROPERTY: foreach my $property ( qw(Id User Host db State Command Info) ) { my $filter = "_find_match_$property"; if ( defined $find_spec{ignore}->{$property} && $self->$filter($query, $find_spec{ignore}->{$property}) ) { PTDEBUG && _d('Query matches ignore', $property, 'spec'); next QUERY; } if ( defined $find_spec{match}->{$property} ) { if ( !$self->$filter($query, $find_spec{match}->{$property}) ) { PTDEBUG && _d('Query does not match', $property, 'spec'); next QUERY; } my $reason = 'Query matches ' . $property . ' spec'; PTDEBUG && _d($reason); push @{$self->{_reasons_for_matching}->{$query} ||= []}, $reason; $matched++; } } if ( $matched || $find_spec{all} ) { PTDEBUG && _d("Query matched one or more specs, adding"); push @matches, $query; next QUERY; } PTDEBUG && _d('Query does not match any specs, ignoring'); } # QUERY return @matches; } sub _find_match_Id { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Id} && $query->{Id} == $property; } sub _find_match_User { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{User} && $query->{User} =~ m/$property/; } sub _find_match_Host { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Host} && $query->{Host} =~ m/$property/; } sub _find_match_db { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{db} && $query->{db} =~ m/$property/; } sub _find_match_State { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{State} && $query->{State} =~ m/$property/; } sub _find_match_Command { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Command} && $query->{Command} =~ m/$property/; } sub _find_match_Info { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Info} && $query->{Info} =~ m/$property/; } 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 Processlist 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 # ########################################################################### # ########################################################################### # 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$|cluster$|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}; my $o = $self->{OptionParser}; $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)); my $slave_dsn = $dsn; if ($o->got('slave-user')) { $slave_dsn->{u} = $o->get('slave-user'); PTDEBUG && _d("Using slave user ".$o->get('slave-user')." on ".$slave_dsn->{h}.":".$slave_dsn->{P}); } if ($o->got('slave-password')) { $slave_dsn->{p} = $o->get('slave-password'); PTDEBUG && _d("Slave password set"); } push @$slaves, $make_cxn->(dsn => $slave_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 FULL 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 # ########################################################################### # ########################################################################### # 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; our $verbs = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT |UPDATE|DELETE|REPLACE|^SET|UNION|^START|^LOCK}xi; my $quote_re = qr/"(?:(?!(? [^()]+ ) # Non-parens without backtracking | (??{ $bal }) # Group with matching parens )* \) /x; my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/; # One-line comments my $mlc_re = qr#/\*[^!].*?\*/#sm; # But not /*!version */ my $vlc_re = qr#/\*.*?[0-9]+.*?\*/#sm; # For SHOW + /*!version */ my $vlc_rf = qr#^(?:SHOW).*?/\*![0-9]+(.*?)\*/#sm; # Variation for SHOW sub new { my ( $class, %args ) = @_; my $self = { %args }; return bless $self, $class; } sub strip_comments { my ( $self, $query ) = @_; return unless $query; $query =~ s/$mlc_re//go; $query =~ s/$olc_re//go; if ( $query =~ m/$vlc_rf/i ) { # contains show + version my $qualifier = $1 || ''; $query =~ s/$vlc_re/$qualifier/go; } return $query; } sub shorten { my ( $self, $query, $length ) = @_; $query =~ s{ \A( (?:INSERT|REPLACE) (?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)? (?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\) ) \s*,\s*\(.*?(ON\s+DUPLICATE|\Z)} {$1 /*... omitted ...*/$2}xsi; return $query unless $query =~ m/IN\s*\(\s*(?!select)/i; my $last_length = 0; my $query_length = length($query); while ( $length > 0 && $query_length > $length && $query_length < ( $last_length || $query_length + 1 ) ) { $last_length = $query_length; $query =~ s{ (\bIN\s*\() # The opening of an IN list ([^\)]+) # Contents of the list, assuming no item contains paren (?=\)) # Close of the list } { $1 . __shorten($2) }gexsi; } return $query; } sub __shorten { my ( $snippet ) = @_; my @vals = split(/,/, $snippet); return $snippet unless @vals > 20; my @keep = splice(@vals, 0, 20); # Remove and save the first 20 items return join(',', @keep) . "/*... omitted " . scalar(@vals) . " items ...*/"; } sub fingerprint { my ( $self, $query ) = @_; $query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query && return 'mysqldump'; $query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/# # pt-table-checksum, etc query && return 'percona-toolkit'; $query =~ m/\Aadministrator command: / && return $query; $query =~ m/\A\s*(call\s+\S+)\(/i && return lc($1); # Warning! $1 used, be careful. if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)?\s+INTO.+?VALUES\s*\(.*?\))\s*,\s*\(/is ) { $query = $beginning; # Shorten multi-value INSERT statements ASAP } $query =~ s/$mlc_re//go; $query =~ s/$olc_re//go; $query =~ s/\Ause \S+\Z/use ?/i # Abstract the DB in USE && return $query; $query =~ s/\\["']//g; # quoted strings $query =~ s/".*?"/?/sg; # quoted strings $query =~ s/'.*?'/?/sg; # quoted strings $query =~ s/\bfalse\b|\btrue\b/?/isg; # boolean values if ( $self->{match_md5_checksums} ) { $query =~ s/([._-])[a-f0-9]{32}/$1?/g; } if ( !$self->{match_embedded_numbers} ) { $query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g; } else { $query =~ s/\b[0-9+-][0-9a-f.xb+-]*/?/g; } if ( $self->{match_md5_checksums} ) { $query =~ s/[xb+-]\?/?/g; } else { $query =~ s/[xb.+-]\?/?/g; } $query =~ s/\A\s+//; # Chop off leading whitespace chomp $query; # Kill trailing whitespace $query =~ tr[ \n\t\r\f][ ]s; # Collapse whitespace $query = lc $query; $query =~ s/\bnull\b/?/g; # Get rid of NULLs $query =~ s{ # Collapse IN and VALUES lists \b(in|values?)(?:[\s,]*\([\s?,]*\))+ } {$1(?+)}gx; $query =~ s{ # Collapse UNION \b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+ } {$1 /*repeat$2*/}xg; $query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT if ( $query =~ m/\bORDER BY /gi ) { # Find, anchor on ORDER BY clause 1 while $query =~ s/\G(.+?)\s+ASC/$1/gi && pos $query; } return $query; } sub distill_verbs { my ( $self, $query ) = @_; $query =~ m/\A\s*call\s+(\S+)\(/i && return "CALL $1"; $query =~ m/\A\s*use\s+/ && return "USE"; $query =~ m/\A\s*UNLOCK TABLES/i && return "UNLOCK"; $query =~ m/\A\s*xa\s+(\S+)/i && return "XA_$1"; if ( $query =~ m/\A\s*LOAD/i ) { my ($tbl) = $query =~ m/INTO TABLE\s+(\S+)/i; $tbl ||= ''; $tbl =~ s/`//g; return "LOAD DATA $tbl"; } if ( $query =~ m/\Aadministrator command:/ ) { $query =~ s/administrator command:/ADMIN/; $query = uc $query; return $query; } $query = $self->strip_comments($query); if ( $query =~ m/\A\s*SHOW\s+/i ) { PTDEBUG && _d($query); $query = uc $query; $query =~ s/\s+(?:SESSION|FULL|STORAGE|ENGINE)\b/ /g; $query =~ s/\s+COUNT[^)]+\)//g; $query =~ s/\s+(?:FOR|FROM|LIKE|WHERE|LIMIT|IN)\b.+//ms; $query =~ s/\A(SHOW(?:\s+\S+){1,2}).*\Z/$1/s; $query =~ s/\s+/ /g; PTDEBUG && _d($query); return $query; } eval $QueryParser::data_def_stmts; eval $QueryParser::tbl_ident; my ( $dds ) = $query =~ /^\s*($QueryParser::data_def_stmts)\b/i; if ( $dds) { $query =~ s/\s+IF(?:\s+NOT)?\s+EXISTS/ /i; my ( $obj ) = $query =~ m/$dds.+(DATABASE|TABLE)\b/i; $obj = uc $obj if $obj; PTDEBUG && _d('Data def statment:', $dds, 'obj:', $obj); my ($db_or_tbl) = $query =~ m/(?:TABLE|DATABASE)\s+($QueryParser::tbl_ident)(\s+.*)?/i; PTDEBUG && _d('Matches db or table:', $db_or_tbl); return uc($dds . ($obj ? " $obj" : '')), $db_or_tbl; } my @verbs = $query =~ m/\b($verbs)\b/gio; @verbs = do { my $last = ''; grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs; }; if ( ($verbs[0] || '') eq 'SELECT' && @verbs > 1 ) { PTDEBUG && _d("False-positive verbs after SELECT:", @verbs[1..$#verbs]); my $union = grep { $_ eq 'UNION' } @verbs; @verbs = $union ? qw(SELECT UNION) : qw(SELECT); } my $verb_str = join(q{ }, @verbs); return $verb_str; } sub __distill_tables { my ( $self, $query, $table, %args ) = @_; my $qp = $args{QueryParser} || $self->{QueryParser}; die "I need a QueryParser argument" unless $qp; my @tables = map { $_ =~ s/`//g; $_ =~ s/(_?)[0-9]+/$1?/g; $_; } grep { defined $_ } $qp->get_tables($query); push @tables, $table if $table; @tables = do { my $last = ''; grep { my $pass = $_ ne $last; $last = $_; $pass } @tables; }; return @tables; } sub distill { my ( $self, $query, %args ) = @_; if ( $args{generic} ) { my ($cmd, $arg) = $query =~ m/^(\S+)\s+(\S+)/; return '' unless $cmd; $query = (uc $cmd) . ($arg ? " $arg" : ''); } else { my ($verbs, $table) = $self->distill_verbs($query, %args); if ( $verbs && $verbs =~ m/^SHOW/ ) { my %alias_for = qw( SCHEMA DATABASE KEYS INDEX INDEXES INDEX ); map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for; $query = $verbs; } elsif ( $verbs && $verbs =~ m/^LOAD DATA/ ) { return $verbs; } else { my @tables = $self->__distill_tables($query, $table, %args); $query = join(q{ }, $verbs, @tables); } } if ( $args{trf} ) { $query = $args{trf}->($query, %args); } return $query; } sub convert_to_select { my ( $self, $query ) = @_; return unless $query; return if $query =~ m/=\s*\(\s*SELECT /i; $query =~ s{ \A.*? update(?:\s+(?:low_priority|ignore))?\s+(.*?) \s+set\b(.*?) (?:\s*where\b(.*?))? (limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)? \Z } {__update_to_select($1, $2, $3, $4)}exsi || $query =~ s{ \A.*? (?:insert(?:\s+ignore)?|replace)\s+ .*?\binto\b(.*?)\(([^\)]+)\)\s* values?\s*(\(.*?\))\s* (?:\blimit\b|on\s+duplicate\s+key.*)?\s* \Z } {__insert_to_select($1, $2, $3)}exsi || $query =~ s{ \A.*? (?:insert(?:\s+ignore)?|replace)\s+ (?:.*?\binto)\b(.*?)\s* set\s+(.*?)\s* (?:\blimit\b|on\s+duplicate\s+key.*)?\s* \Z } {__insert_to_select_with_set($1, $2)}exsi || $query =~ s{ \A.*? delete\s+(.*?) \bfrom\b(.*) \Z } {__delete_to_select($1, $2)}exsi; $query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si; $query =~ s/\A.*?(?=\bSELECT\s*\b)//ism; return $query; } sub convert_select_list { my ( $self, $query ) = @_; $query =~ s{ \A\s*select(.*?)\bfrom\b } {$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi; return $query; } sub __delete_to_select { my ( $delete, $join ) = @_; if ( $join =~ m/\bjoin\b/ ) { return "select 1 from $join"; } return "select * from $join"; } sub __insert_to_select { my ( $tbl, $cols, $vals ) = @_; PTDEBUG && _d('Args:', @_); my @cols = split(/,/, $cols); PTDEBUG && _d('Cols:', @cols); $vals =~ s/^\(|\)$//g; # Strip leading/trailing parens my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g; PTDEBUG && _d('Vals:', @vals); if ( @cols == @vals ) { return "select * from $tbl where " . join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols)); } else { return "select * from $tbl limit 1"; } } sub __insert_to_select_with_set { my ( $from, $set ) = @_; $set =~ s/,/ and /g; return "select * from $from where $set "; } sub __update_to_select { my ( $from, $set, $where, $limit ) = @_; return "select $set from $from " . ( $where ? "where $where" : '' ) . ( $limit ? " $limit " : '' ); } sub wrap_in_derived { my ( $self, $query ) = @_; return unless $query; return $query =~ m/\A\s*select/i ? "select 1 from ($query) as x limit 1" : $query; } 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 QueryRewriter 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/; } 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 # ########################################################################### # ########################################################################### # 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_kill; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use POSIX qw(setsid); use List::Util qw(max); use Digest::MD5 qw(md5_hex); use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; Transformers->import(qw(ts)); use Percona::Toolkit; use constant PTDEBUG => $ENV{PTDEBUG} || 0; $OUTPUT_AUTOFLUSH = 1; my $o; # ######################################################################## # Configuration info. # ######################################################################## sub main { local @ARGV = @_; # set global ARGV for this package # ######################################################################## # Get configuration information. # ######################################################################## $o = new OptionParser(); $o->get_specs(); $o->get_opts(); my $dp = $o->DSNParser(); $dp->prop('set-vars', $o->set_vars()); if ( !$o->got('busy-time') ) { $o->set('interval', 30) unless $o->got('interval'); } else { $o->set('interval', max(1, $o->get('busy-time') / 2)) unless $o->got('interval'); } # Disable opts that don't make sense when reading proclist # from a file (or STDIN). if ( $o->get('test-matching') ) { $o->set('run-time', 0); $o->set('interval', 0); $o->set('ignore-self', 0); } # TODO: parse valid values from POD my $victims = lc $o->get('victims'); if ( !grep { $victims eq $_ } qw(oldest all all-but-oldest) ) { $o->save_error("Invalid value for --victims: $victims"); } $o->usage_or_errors(); # ######################################################################## # First things first: if --stop was given, create the sentinel file. # ######################################################################## if ( $o->get('stop') ) { my $sentinel = $o->get('sentinel'); PTDEBUG && _d('Creating sentinel file', $sentinel); open my $fh, '>', $sentinel or die "Cannot open $sentinel: $OS_ERROR\n"; print $fh "Remove this file to permit pt-kill to run.\n" or die "Cannot write to $sentinel: $OS_ERROR\n"; close $fh or die "Cannot close $sentinel: $OS_ERROR\n"; print "Successfully created file $sentinel\n"; return 0; } # ######################################################################## # Create the --filter sub. # ######################################################################## my $filter_sub; if ( my $filter = $o->get('filter') ) { if ( -f $filter && -r $filter ) { PTDEBUG && _d('Reading file', $filter, 'for --filter code'); open my $fh, "<", $filter or die "Cannot open $filter: $OS_ERROR"; $filter = do { local $/ = undef; <$fh> }; close $fh; } else { $filter = "( $filter )"; # issue 565 } my $code = 'sub { my ( $event ) = @_; ' . "$filter && return \$event; };"; PTDEBUG && _d('--filter code:', $code); $filter_sub = eval $code or die "Error compiling --filter code: $code\n$EVAL_ERROR"; } # ######################################################################## # Make input sub that will either get processlist from MySQL or a file. # ######################################################################## my $ms = new MasterSlave( OptionParser => $o, DSNParser => $dp, Quoter => "Quoter", ); my $pl = new Processlist(MasterSlave => $ms); my $qr = new QueryRewriter(); my $cxn; my $dbh; # $cxn->dbh my $get_proclist; # callback to SHOW PROCESSLIST my $proc_sth; my $kill; # callback to KILL my $kill_sth; my $kill_sql; if ( $o->get('rds') ){ $kill_sql = $o->get('kill-query') ? 'CALL mysql.rds_kill_query(?)' : 'CALL mysql.rds_kill(?)'; } else{ $kill_sql = $o->get('kill-query') ? 'KILL QUERY ?' : 'KILL ?'; } my $files; if ( $files = $o->get('test-matching') ) { PTDEBUG && _d('Getting processlist from files:', @$files); my $trp = new TextResultSetParser(); my $fh; $get_proclist = sub { if ( !$fh ) { my $file = shift @$files; die 'No more files' unless $file; if ( $file eq '-' ) { $fh = *STDIN; } else { if ( !open $fh, '<', $file ) { warn "Cannot open $file: $OS_ERROR"; $fh = undef; return; } } } if ( $fh ) { local $INPUT_RECORD_SEPARATOR = ''; my $proclist_text = <$fh>; if ( $proclist_text ) { return $trp->parse($proclist_text); } else { # No more proclists in this file. $fh = undef; } } return; }; } else { PTDEBUG && _d('Getting processlist from MySQL'); $cxn = Cxn->new( dsn_string => shift @ARGV, NAME_lc => 0, parent => $o->get('daemonize'), DSNParser => $dp, OptionParser => $o, ); $dbh = $cxn->connect(); # Make the get_proclist and kill callbacks. Use Retry in case # the connection to MySQL is lost, then the dbh and the sths # will need to be re-initialized. my $retry = Retry->new(); $proc_sth = $dbh->prepare('SHOW FULL PROCESSLIST'); $get_proclist = sub { return $retry->retry( # Retry for an hour: 1,200 tries x 3 seconds = 3600s/1hr tries => 1200, wait => sub { sleep 3; }, try => sub { $proc_sth->execute(); return $proc_sth->fetchall_arrayref({}); }, fail => sub { my (%args) = @_; my $error = $args{error}; # The 1st pattern means that MySQL itself died or was stopped. # The 2nd pattern means that our cxn was killed (KILL ). if ( $error =~ m/MySQL server has gone away/ || $error =~ m/Lost connection to MySQL server/ ) { eval { $dbh = $cxn->connect(); $proc_sth = $dbh->prepare('SHOW FULL PROCESSLIST'); msg('Reconnected to ' . $cxn->name()); }; return 1 unless $EVAL_ERROR; # try again } return 0; # call final_fail }, final_fail => sub { my (%args) = @_; die $args{error}; }, ); }; $kill_sth = $dbh->prepare($kill_sql); $kill = sub { my ($id) = @_; PTDEBUG && _d('Killing process', $id); return $retry->retry( tries => 2, try => sub { return $kill_sth->execute($id); }, fail => sub { my (%args) = @_; my $error = $args{error}; # The 1st pattern means that MySQL itself died or was stopped. # The 2nd pattern means that our cxn was killed (KILL ). if ( $error =~ m/MySQL server has gone away/ || $error =~ m/Lost connection to MySQL server/ ) { eval { $dbh = $cxn->connect(); $kill_sth = $dbh->prepare($kill_sql); msg('Reconnected to ' . $cxn->name()); }; return 1 unless $EVAL_ERROR; # try again } return 0; # call final_fail }, final_fail => sub { my (%args) = @_; die $args{error}; }, ); }; } # Set up --log-dsn if specified. my ($log, $log_dsn, $log_sql, $log_sth, $log_cxn); my @processlist_columns = qw( Id User Host db Command Time State Info Time_ms ); if ( $log_dsn = $o->get('log-dsn') ) { my $db = $log_dsn->{D}; my $table = $log_dsn->{t}; die "--log-dsn does not specify a database (D) " . "or a database-qualified table (t)" unless defined $table && defined $db; PTDEBUG && _d('Connecting --log-dsn:', Dumper($log_dsn)); $log_cxn = Cxn->new( dsn => $log_dsn, NAME_lc => 0, DSNParser => $dp, OptionParser => $o, ); my $log_dbh = $log_cxn->connect(); my $log_table = Quoter->quote($db, $table); PTDEBUG && _d('Connected --log-dsn:', Dumper($log_cxn->dsn)); # Create the log-table table if it doesn't exist and --create-log-table # was passed in my $tp = TableParser->new( Quoter => "Quoter" ); if ( !$tp->check_table( dbh => $log_dbh, db => $db, tbl => $table ) ) { if ($o->get('create-log-table') ) { my $sql = $o->read_para_after( __FILE__, qr/MAGIC_create_log_table/); $sql =~ s/kill_log/IF NOT EXISTS $log_table/; PTDEBUG && _d($sql); $log_dbh->do($sql); } else { die "--log-dsn table does not exist. Please create it or specify " . "--create-log-table."; } } # All the columns of the table that we care about my @all_log_columns = ( qw( server_id timestamp reason kill_error ), @processlist_columns ); my $sql = 'SELECT @@SERVER_ID'; PTDEBUG && _d($sql); my ($server_id) = $dbh->selectrow_array($sql); $log_sql = "INSERT INTO $log_table (" . join(", ", @all_log_columns) . ") VALUES(" . join(", ", $server_id, ("?") x (@all_log_columns-1)) . ")"; PTDEBUG && _d($sql); $log_sth = $log_dbh->prepare($log_sql); my $retry = Retry->new(); $log = sub { my (@params) = @_; PTDEBUG && _d('Logging values:', @params); return $retry->retry( tries => 3, wait => sub { sleep 3; }, try => sub { return $log_sth->execute(@params); }, fail => sub { my (%args) = @_; my $error = $args{error}; # The 1st pattern means that MySQL itself died or was stopped. # The 2nd pattern means that our cxn was killed (KILL ). if ( $error =~ m/MySQL server has gone away/ || $error =~ m/Lost connection to MySQL server/ ) { eval { $log_dbh = $log_cxn->connect(); $log_sth = $log_dbh->prepare($log_sql); msg('Reconnected to ' . $cxn->name()); }; if ( $EVAL_ERROR ) { warn "Fail code failed: $EVAL_ERROR"; } return 1; # retry } return 0; # call final_fail }, final_fail => sub { my (%args) = @_; die $args{error}; }, ); }; } # ######################################################################## # 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(); } # If we daemonized, the parent has already exited and we're the child. # We shared a copy of every Cxn with the parent, and the parent's copies # were destroyed but the dbhs were not disconnected because the parent # attrib was true. Now, as the child, set it false so the dbhs will be # disconnected when our Cxn copies are destroyed. If we didn't daemonize, # then we're not really a parent (since we have no children), so set it # false to auto-disconnect the dbhs when our Cxns are destroyed. $cxn->{parent} = 0 if $cxn; # ######################################################################## # 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 => $dbh, dsn => $cxn->dsn() } : ()) ], ); } # ######################################################################## # Start working. # ######################################################################## msg("$PROGRAM_NAME starting"); msg($dbh ? "Connected to host " . $cxn->name() : "Test matching files @$files"); # Class-based match criteria. my $query_count = $o->get('query-count'); my $each_busy_time = $o->get('each-busy-time'); my $any_busy_time = $o->get('any-busy-time'); my $group_by = $o->get('group-by'); if ( $group_by && $group_by =~ m/id|user|host|db|command|time|state|info/i ) { # Processlist.pm is case-sensitive. It matches Id, Host, db, etc. # So we'll do the same because if we set NAME_lc on the dbh then # we'll break our Processlist obj. $group_by = lc $group_by; $group_by = ucfirst $group_by unless $group_by eq 'db'; } # Per-class match criteria. my %find_spec = ( busy_time => $o->get('busy-time'), idle_time => $o->get('idle-time'), all => $o->get('match-all'), replication_threads => $o->get('replication-threads'), ignore => { Command => $o->get('ignore-command'), db => $o->get('ignore-db'), Host => $o->get('ignore-host'), Id => $o->get('ignore-self') ? $dbh->{mysql_thread_id} : undef, Info => $o->get('ignore-info'), State => $o->get('ignore-state'), User => $o->get('ignore-user'), }, match => { Command => $o->get('match-command'), db => $o->get('match-db'), Host => $o->get('match-host'), Info => $o->get('match-info'), State => $o->get('match-state'), User => $o->get('match-user'), }, ); msg("Find spec: " . Dumper(\%find_spec)); my $sentinel = $o->get('sentinel'); my $run_time = $o->get('run-time') || 0; my $start = time(); my $end = $start + $run_time; # When we should exit my $now = $start; if ( $dbh ) { msg("Run-time: " . ($run_time ? "$run_time seconds" : "forever") . " at " . ($o->get('interval') || 0) . " second intervals"); } # We don't care about the executed command, and we don't want # to wait for it, so we ignore dead children so we don't have # to reap them and they won't become zombies. # https://bugs.launchpad.net/percona-toolkit/+bug/919819 if ( $o->get('execute-command') ) { $SIG{CHLD} = 'IGNORE'; } while ( (!$run_time || $now < $end) && !-f $sentinel ) { msg('Checking processlist'); my $proclist; eval { $proclist = $get_proclist->(); }; if ( $EVAL_ERROR ) { last if $EVAL_ERROR =~ m/No more files/; die "Error getting SHOW PROCESSLIST: $EVAL_ERROR"; } # Apply --filter to the processlist events. my $filtered_proclist; if ( $filter_sub && $proclist && @$proclist ) { foreach my $proc ( @$proclist ) { push @$filtered_proclist, $proc if $filter_sub->($proc); } } else { $filtered_proclist = $proclist; } $proclist = $filtered_proclist; my @queries; if ( $proclist ) { # ################################################################## # Group queries into classes. If --group-by wasn't specified # then all queries will be put in the "default" class. # ################################################################## my $query_classes = group_queries( proclist => $proclist, group_by => $group_by, strip_comments => $o->get('strip-comments'), QueryRewriter => $qr, ); # ################################################################## # Find matching queries in each class. # ################################################################## CLASS: foreach my $class ( keys %$query_classes ) { PTDEBUG && _d('Finding matching queries in class', $class); my @matches = $pl->find($query_classes->{$class}, %find_spec); PTDEBUG && _d(scalar @matches, 'queries in class', $class); next CLASS unless scalar @matches; # ############################################################### # Apply class-based filters. # ############################################################### if ( $query_count && @matches < $query_count ) { PTDEBUG && _d('Not enough queries in class', $class, '; has', scalar @matches, 'but needs at least', $query_count); next CLASS; } if ( $each_busy_time ) { foreach my $proc ( @matches ) { if ( ($proc->{Time} || 0) <= $each_busy_time ) { PTDEBUG && _d('This query in class', $class, 'hasn\'t been running long enough:', Dumper($proc)); next CLASS; } } } elsif ( $any_busy_time ) { my $busy_enough = 0; foreach my $proc ( @matches ) { if ( ($proc->{Time} || 0) > $any_busy_time ) { $busy_enough = 1; last; } } if ( !$busy_enough ) { PTDEBUG && _d('No query is busy enough in class', $class); next CLASS; } } # ############################################################### # Select the victims (which of the matching queries to kill). # ############################################################### @matches = reverse sort { ($a->{Time} || 0) <=> ($b->{Time} || 0) } @matches; if ( $victims eq 'oldest' ) { @matches = ($matches[0]); } elsif ( $victims eq 'all-but-oldest' ) { shift @matches; # remove fist/oldest query } elsif ( $victims eq 'all' ) { # Don't do anything. } else { # Shouldn't happen. Option val should be verified earlier. die "I don't know how to kill $victims"; } # ############################################################### # Save matching queries in this class. # ############################################################### PTDEBUG && _d(scalar @matches, 'queries to kill in class', $class); push @queries, @matches; } # CLASS msg('Matched ' . scalar @queries . ' queries'); MATCHING_QUERY: foreach my $query ( @queries ) { if ( $o->get('print') ) { printf "# %s %s %d (%s %d sec) %s\n", ts(time), $o->get('kill-query') ? 'KILL QUERY' : 'KILL', $query->{Id}, ($query->{Command} || 'NULL'), $query->{Time}, ($query->{Info} || 'NULL'); } if ( $o->get('query-id') ) { my $fp = $qr->fingerprint($query->{'Info'}); my $chksm = Transformers::make_checksum($fp); print "Query ID: 0x$chksm\n"; } if ( $o->get('execute-command') ) { exec_cmd($o->get('execute-command')); msg('Executed ' . $o->get('execute-command')); } if ( $o->get('kill') || $o->get('kill-query') ) { if ( $o->get('wait-before-kill') ) { msg("Sleeping " . $o->get('wait-before-kill') . " seconds before kill"); sleep $o->get('wait-before-kill'); } local $@; eval { $kill->($query->{Id}) }; if ( $log ) { log_to_table( log => $log, query => $query, proclist => $pl, columns => \@processlist_columns, eval_error => $EVAL_ERROR, ); } if ( $EVAL_ERROR ) { msg("Error killing $query->{Id}: $EVAL_ERROR"); } else { msg("Killed $query->{Id}"); } } } } else { msg('Processlist returned no queries'); } if ( $dbh ) { if ( @queries && $o->get('wait-after-kill') ) { msg("Sleeping " . $o->get('wait-after-kill') . " seconds after killing queries"); sleep $o->get('wait-after-kill'); } else { msg("Sleeping " . $o->get('interval') . " seconds after normal interval"); sleep $o->get('interval'); } } $now = time(); } msg("Sentinel file $sentinel exists") if $sentinel && -f $sentinel; msg("$PROGRAM_NAME ending"); return 0; } # ############################################################################ # Subroutines. # ############################################################################ # Forks and detaches from parent to execute the given command; # does not block parent. sub exec_cmd { my ( $cmd ) = @_; PTDEBUG && _d('exec cmd:', $cmd); return unless $cmd; my $pid = fork(); if ( $pid ) { # parent PTDEBUG && _d('child pid:', $pid); return $pid; } # child POSIX::setsid() or die "Cannot start a new session: $OS_ERROR"; my $retval = system($cmd); $retval = $retval >> 8; PTDEBUG && _d('child exit status:', $retval); exit $retval; } sub msg { my ( $msg ) = @_; print '# ', ts(time), " $msg\n" if $o->get('verbose'); PTDEBUG && _d($msg); return; } sub log_to_table { my (%args) = @_; my ($log, $query, $pl, $processlist_columns) = @args{qw( log query proclist columns )}; my $ts = Transformers::ts(time()); my $reasons = join "\n", map { defined($_) ? $_ : "Unkown reason" } @{ $pl->{_reasons_for_matching}->{$query} }; $log->( $ts, $reasons, $args{eval_error}, @{$query}{@$processlist_columns} ); } sub group_queries { my ( %args ) = @_; my ($proclist, $group_by, $qr) = @args{qw(proclist group_by QueryRewriter)}; PTDEBUG && _d("Grouping queries by", $group_by); # If there's proclist then there's nothing to do. If there's no group by # then all the procs in the list are in the same class. return $proclist unless $proclist; return { 'default' => $proclist } unless $group_by; my $query_classes = {}; foreach my $proc ( @$proclist ) { if ( $args{strip_comments} && $proc->{Info} ) { $proc->{Info} = $qr->strip_comments($proc->{Info}); } my $class; if ( $group_by eq 'fingerprint' ) { $class = $proc->{Info} ? $qr->fingerprint($proc->{Info}) : 'NULL'; } else { $class = $proc->{$group_by} ? $proc->{$group_by} : 'NULL'; } push @{$query_classes->{$class}}, $proc; } return $query_classes; } 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-kill - Kill MySQL queries that match certain criteria. =head1 SYNOPSIS Usage: pt-kill [OPTIONS] [DSN] pt-kill kills MySQL connections. pt-kill connects to MySQL and gets queries from SHOW PROCESSLIST if no FILE is given. Else, it reads queries from one or more FILE which contains the output of SHOW PROCESSLIST. If FILE is -, pt-kill reads from STDIN. Kill queries running longer than 60s: pt-kill --busy-time 60 --kill Print, do not kill, queries running longer than 60s: pt-kill --busy-time 60 --print Check for sleeping processes and kill them all every 10s: pt-kill --match-command Sleep --kill --victims all --interval 10 Print all login processes: pt-kill --match-state login --print --victims all See which queries in the processlist right now would match: mysql -e "SHOW PROCESSLIST" > proclist.txt pt-kill --test-matching proclist.txt --busy-time 60 --print =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-kill captures queries from SHOW PROCESSLIST, filters them, and then either kills or prints them. This is also known as a "slow query sniper" in some circles. The idea is to watch for queries that might be consuming too many resources, and kill them. For brevity, we talk about killing queries, but they may just be printed (or some other future action) depending on what options are given. Normally pt-kill connects to MySQL to get queries from SHOW PROCESSLIST. Alternatively, it can read SHOW PROCESSLIST output from files. In this case, pt-kill does not connect to MySQL and L<"--kill"> has no effect. You should use L<"--print"> instead when reading files. The ability to read a file with L<"--test-matching"> allows you to capture SHOW PROCESSLIST and test it later with pt-kill to make sure that your matches kill the proper queries. There are a lot of special rules to follow, such as "don't kill replication threads," so be careful not to kill something important! Two important options to know are L<"--busy-time"> and L<"--victims">. First, whereas most match/filter options match their corresponding value from SHOW PROCESSLIST (e.g. L<"--match-command"> matches a query's Command value), the Time value is matched by L<"--busy-time">. See also L<"--interval">. Second, L<"--victims"> controls which matching queries from each class are killed. By default, the matching query with the highest Time value is killed (the oldest query). See the next section, L<"GROUP, MATCH AND KILL">, for more details. Usually you need to specify at least one C<--match> option, else no queries will match. Or, you can specify L<"--match-all"> to match all queries that aren't ignored by an C<--ignore> option. =head1 GROUP, MATCH AND KILL Queries pass through several steps to determine which exactly will be killed (or printed--whatever action is specified). Understanding these steps will help you match precisely the queries you want. The first step is grouping queries into classes. The L<"--group-by"> option controls grouping. By default, this option has no value so all queries are grouped into one default class. All types of matching and filtering (the next step) are applied per-class. Therefore, you may need to group queries in order to match/filter some classes but not others. The second step is matching. Matching implies filtering since if a query doesn't match some criteria, it is removed from its class. Matching happens for each class. First, queries are filtered from their class by the various C options like L<"--match-user">. Then, entire classes are filtered by the various C options like L<"--query-count">. The third step is victim selection, that is, which matching queries in each class to kill. This is controlled by the L<"--victims"> option. Although many queries in a class may match, you may only want to kill the oldest query, or all queries, etc. The forth and final step is to take some action on all matching queries from all classes. The C options specify which actions will be taken. At this step, there are no more classes, just a single list of queries to kill, print, etc. =head1 OUTPUT If only L<"--kill"> is given, then there is no output. If only L<"--print"> is given, then a timestamped KILL statement if printed for every query that would have been killed, like: # 2009-07-15T15:04:01 KILL 8 (Query 42 sec) SELECT * FROM huge_table The line shows a timestamp, the query's Id (8), its Time (42 sec) and its Info (usually the query SQL). If both L<"--kill"> and L<"--print"> are given, then matching queries are killed and a line for each like the one above is printed. Any command executed by L<"--execute-command"> is responsible for its own output and logging. After being executed, pt-kill has no control or interaction with the command. =head1 OPTIONS Specify at least one of L<"--kill">, L<"--kill-query">, L<"--print">, L<"--execute-command"> or L<"--stop">. L<"--any-busy-time"> and L<"--each-busy-time"> are mutually exclusive. L<"--kill"> and L<"--kill-query"> are mutually exclusive. L<"--daemonize"> and L<"--test-matching"> 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 --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-log-table Create the L<"--log-dsn"> table if it does not exist. This option causes the table specified by L<"--log-dsn"> to be created with the default structure shown in the documentation for that option. =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 --defaults-file short form: -F; type: string Only read mysql options from the given file. You must give an absolute pathname. =item --filter type: string Discard events for which this Perl code doesn't return true. This option is a string of Perl code or a file containing Perl code that gets compiled into a subroutine with one argument: $event. This is a hashref. If the given value is a readable file, then pt-kill reads the entire file and uses its contents as the code. The file should not contain a shebang (#!/usr/bin/perl) line. If the code returns true, the chain of callbacks continues; otherwise it ends. The code is the last statement in the subroutine other than C. The subroutine template is: sub { $event = shift; filter && return $event; } Filters given on the command line are wrapped inside parentheses like like C<( filter )>. For complex, multi-line filters, you must put the code inside a file so it will not be wrapped inside parentheses. Either way, the filter must produce syntactically valid code given the template. For example, an if-else branch given on the command line would not be valid: --filter 'if () { } else { }' # WRONG Since it's given on the command line, the if-else branch would be wrapped inside parentheses which is not syntactically valid. So to accomplish something more complex like this would require putting the code in a file, for example filter.txt: my $event_ok; if (...) { $event_ok=1; } else { $event_ok=0; } $event_ok Then specify C<--filter filter.txt> to read the code from filter.txt. If the filter code won't compile, pt-kill will die with an error. If the filter code does compile, an error may still occur at runtime if the code tries to do something wrong (like pattern match an undefined value). pt-kill does not provide any safeguards so code carefully! It is permissible for the code to have side effects (to alter C<$event>). =item --group-by type: string Apply matches to each class of queries grouped by this SHOW PROCESSLIST column. In addition to the basic columns of SHOW PROCESSLIST (user, host, command, state, etc.), queries can be matched by C which abstracts the SQL query in the C column. By default, queries are not grouped, so matches and actions apply to all queries. Grouping allows matches and actions to apply to classes of similar queries, if any queries in the class match. For example, detecting cache stampedes (see C under L<"--victims"> for an explanation of that term) requires that queries are grouped by the C attribute. This creates classes of identical queries (stripped of comments). So queries C<"SELECT c FROM t WHERE id=1"> and C<"SELECT c FROM t WHERE id=1"> are grouped into the same class, but query c<"SELECT c FROM t WHERE id=3"> is not identical to the first two queries so it is grouped into another class. Then when L<"--victims"> C is specified, all but the oldest query in each class is killed for each class of queries that matches the match criteria. =item --help Show help and exit. =item --host short form: -h; type: string; default: localhost Connect to host. =item --interval type: time How often to check for queries to kill. If L<"--busy-time"> is not given, then the default interval is 30 seconds. Else the default is half as often as L<"--busy-time">. If both L<"--interval"> and L<"--busy-time"> are given, then the explicit L<"--interval"> value is used. See also L<"--run-time">. =item --log type: string Print all output to this file when daemonized. =item --log-dsn type: DSN Store each query killed in this DSN. The argument specifies a table to store all killed queries. The DSN passed in must have the databse (D) and table (t) options. The table must have at least the following columns. You can add more columns for your own special purposes, but they won't be used by pt-kill. The following CREATE TABLE definition is also used for L<"--create-log-table">. MAGIC_create_log_table: CREATE TABLE kill_log ( kill_id int(10) unsigned NOT NULL AUTO_INCREMENT, server_id bigint(4) NOT NULL DEFAULT '0', timestamp DATETIME, reason TEXT, kill_error TEXT, Id bigint(4) NOT NULL DEFAULT '0', User varchar(16) NOT NULL DEFAULT '', Host varchar(64) NOT NULL DEFAULT '', db varchar(64) DEFAULT NULL, Command varchar(16) NOT NULL DEFAULT '', Time int(7) NOT NULL DEFAULT '0', State varchar(64) DEFAULT NULL, Info longtext, Time_ms bigint(21) DEFAULT '0', # NOTE, TODO: currently not used PRIMARY KEY (kill_id) ) DEFAULT CHARSET=utf8 =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 --query-id Prints an ID of the query that was just killed. This is equivalent to the "ID" output of pt-query-digest. This allows cross-referencing the output of both tools. Example: Query ID 0xE9800998ECF8427E Note that this is a digest (or hash) of the query's "fingerprint", so queries of the same form but with different values will have the same ID. See pt-query-digest for more information. =item --rds Denotes the instance in question is on Amazon RDS. By default pt-kill runs the MySQL command "kill" for L<"--kill"> and "kill query" L<"--kill-query">. On RDS these two commands are not available and are replaced by function calls. This option modifies L<"--kill"> to use "CALL mysql.rds_kill(thread-id)" instead and L<"--kill-query"> to use "CALL mysql.rds_kill_query(thread-id)" =item --run-time type: time How long to run before exiting. By default pt-kill runs forever, or until its process is killed or stopped by the creation of a L<"--sentinel"> file. If this option is specified, pt-kill runs for the specified amount of time and sleeps L<"--interval"> seconds between each check of the PROCESSLIST. =item --sentinel type: string; default: /tmp/pt-kill-sentinel Exit if this file exists. The presence of the file specified by L<"--sentinel"> will cause all running instances of pt-kill to exit. You might find this handy to stop cron jobs gracefully if necessary. See also L<"--stop">. =item --slave-user type: string Sets the user to be used to connect to the slaves. This parameter allows you to have a different user with less privileges on the slaves but that user must exist on all slaves. =item --slave-password type: string Sets the password to be used to connect to the slaves. It can be used with --slave-user and the password for the user must be the same on all slaves. =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 --stop Stop running instances by creating the L<"--sentinel"> file. Causes pt-kill 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 --[no]strip-comments default: yes Remove SQL comments from queries in the Info column of the PROCESSLIST. =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 --victims type: string; default: oldest Which of the matching queries in each class will be killed. After classes have been matched/filtered, this option specifies which of the matching queries in each class will be killed (or printed, etc.). The following values are possible: =over =item oldest Only kill the single oldest query. This is to prevent killing queries that aren't really long-running, they're just long-waiting. This sorts matching queries by Time and kills the one with the highest Time value. =item all Kill all queries in the class. =item all-but-oldest Kill all but the oldest query. This is the inverse of the C value. This value can be used to prevent "cache stampedes", the condition where several identical queries are executed and create a backlog while the first query attempts to finish. Since all queries are identical, all but the first query are killed so that it can complete and populate the cache. =back =item --wait-after-kill type: time Wait after killing a query, before looking for more to kill. The purpose of this is to give blocked queries a chance to execute, so we don't kill a query that's blocking a bunch of others, and then kill the others immediately afterwards. =item --wait-before-kill type: time Wait before killing a query. The purpose of this is to give L<"--execute-command"> a chance to see the matching query and gather other MySQL or system information before it's killed. =back =head2 QUERY MATCHES These options filter queries from their classes. If a query does not match, it is removed from its class. The C<--ignore> options take precedence. The matches for command, db, host, etc. correspond to the columns returned by SHOW PROCESSLIST: Command, db, Host, etc. All pattern matches are case-sensitive by default, but they can be made case-insensitive by specifying a regex pattern like C<(?i-xsm:select)>. See also L<"GROUP, MATCH AND KILL">. =over =item --busy-time type: time; group: Query Matches Match queries that have been running for longer than this time. The queries must be in Command=Query status. This matches a query's Time value as reported by SHOW PROCESSLIST. =item --idle-time type: time; group: Query Matches Match queries that have been idle/sleeping for longer than this time. The queries must be in Command=Sleep status. This matches a query's Time value as reported by SHOW PROCESSLIST. =item --ignore-command type: string; group: Query Matches Ignore queries whose Command matches this Perl regex. See L<"--match-command">. =item --ignore-db type: string; group: Query Matches Ignore queries whose db (database) matches this Perl regex. See L<"--match-db">. =item --ignore-host type: string; group: Query Matches Ignore queries whose Host matches this Perl regex. See L<"--match-host">. =item --ignore-info type: string; group: Query Matches Ignore queries whose Info (query) matches this Perl regex. See L<"--match-info">. =item --[no]ignore-self default: yes; group: Query Matches Don't kill pt-kill's own connection. =item --ignore-state type: string; group: Query Matches; default: Locked Ignore queries whose State matches this Perl regex. The default is to keep threads from being killed if they are locked waiting for another thread. See L<"--match-state">. =item --ignore-user type: string; group: Query Matches Ignore queries whose user matches this Perl regex. See L<"--match-user">. =item --match-all group: Query Matches Match all queries that are not ignored. If no ignore options are specified, then every query matches (except replication threads, unless L<"--replication-threads"> is also specified). This option allows you to specify negative matches, i.e. "match every query I..." where the exceptions are defined by specifying various C<--ignore> options. This option is I the same as L<"--victims"> C. This option matches all queries within a class, whereas L<"--victims"> C specifies that all matching queries in a class (however they matched) will be killed. Normally, however, the two are used together because if, for example, you specify L<"--victims"> C, then although all queries may match, only the oldest will be killed. =item --match-command type: string; group: Query Matches Match only queries whose Command matches this Perl regex. Common Command values are: Query Sleep Binlog Dump Connect Delayed insert Execute Fetch Init DB Kill Prepare Processlist Quit Reset stmt Table Dump See L for a full list and description of Command values. =item --match-db type: string; group: Query Matches Match only queries whose db (database) matches this Perl regex. =item --match-host type: string; group: Query Matches Match only queries whose Host matches this Perl regex. The Host value often time includes the port like "host:port". =item --match-info type: string; group: Query Matches Match only queries whose Info (query) matches this Perl regex. The Info column of the processlist shows the query that is being executed or NULL if no query is being executed. =item --match-state type: string; group: Query Matches Match only queries whose State matches this Perl regex. Common State values are: Locked login copy to tmp table Copying to tmp table Copying to tmp table on disk Creating tmp table executing Reading from net Sending data Sorting for order Sorting result Table lock Updating See L for a full list and description of State values. =item --match-user type: string; group: Query Matches Match only queries whose User matches this Perl regex. =item --replication-threads group: Query Matches Allow matching and killing replication threads. By default, matches do not apply to replication threads; i.e. replication threads are completely ignored. Specifying this option allows matches to match (and potentially kill) replication threads on masters and slaves. =item --test-matching type: array; group: Query Matches Files with processlist snapshots to test matching options against. Since the matching options can be complex, you can save snapshots of processlist in files, then test matching options against queries in those files. This option disables L<"--run-time">, L<"--interval">, and L<"--[no]ignore-self">. =back =head2 CLASS MATCHES These matches apply to entire query classes. Classes are created by specifying the L<"--group-by"> option, else all queries are members of a single, default class. See also L<"GROUP, MATCH AND KILL">. =over =item --any-busy-time type: time; group: Class Matches Match query class if any query has been running for longer than this time. "Longer than" means that if you specify C<10>, for example, the class will only match if there's at least one query that has been running for greater than 10 seconds. See L<"--each-busy-time"> for more details. =item --each-busy-time type: time; group: Class Matches Match query class if each query has been running for longer than this time. "Longer than" means that if you specify C<10>, for example, the class will only match if each and every query has been running for greater than 10 seconds. See also L<"--any-busy-time"> (to match a class if ANY query has been running longer than the specified time) and L<"--busy-time">. =item --query-count type: int; group: Class Matches Match query class if it has at least this many queries. When queries are grouped into classes by specifying L<"--group-by">, this option causes matches to apply only to classes with at least this many queries. If L<"--group-by"> is not specified then this option causes matches to apply only if there are at least this many queries in the entire SHOW PROCESSLIST. =item --verbose short form: -v Print information to STDOUT about what is being done. =back =head2 ACTIONS These actions are taken for every matching query from all classes. The actions are taken in this order: L<"--print">, L<"--execute-command">, L<"--kill">/L<"--kill-query">. This order allows L<"--execute-command"> to see the output of L<"--print"> and the query before L<"--kill">/L<"--kill-query">. This may be helpful because pt-kill does not pass any information to L<"--execute-command">. See also L<"GROUP, MATCH AND KILL">. =over =item --execute-command type: string; group: Actions Execute this command when a query matches. After the command is executed, pt-kill has no control over it, so the command is responsible for its own info gathering, logging, interval, etc. The command is executed each time a query matches, so be careful that the command behaves well when multiple instances are ran. No information from pt-kill is passed to the command. See also L<"--wait-before-kill">. =item --kill group: Actions Kill the connection for matching queries. This option makes pt-kill kill the connections (a.k.a. processes, threads) that have matching queries. Use L<"--kill-query"> if you only want to kill individual queries and not their connections. Unless L<"--print"> is also given, no other information is printed that shows that pt-kill matched and killed a query. See also L<"--wait-before-kill"> and L<"--wait-after-kill">. =item --kill-query group: Actions Kill matching queries. This option makes pt-kill kill matching queries. This requires MySQL 5.0 or newer. Unlike L<"--kill"> which kills the connection for matching queries, this option only kills the query, not its connection. =item --print group: Actions Print a KILL statement for matching queries; does not actually kill queries. If you just want to see which queries match and would be killed without actually killing them, specify L<"--print">. To both kill and print matching queries, specify both L<"--kill"> and L<"--print">. =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. =item * t Table to log actions in, if passed through --log-dsn. =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-kill ... > 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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2011-2016 Percona LLC and/or its affiliates, 2009-2011 Baron Schwartz. 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 pt-kill 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-query-digest0000775000175000017500000177046613021632517020365 0ustar vagrantvagrant#!/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 Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo DSNParser Quoter OptionParser Transformers QueryRewriter Processlist TcpdumpParser MySQLProtocolParser SlowLogParser SlowLogWriter EventAggregator ReportFormatter QueryReportFormatter JSONReportFormatter EventTimeline QueryParser TableParser QueryReview QueryHistory Daemon BinaryLogParser GeneralLogParser RawLogParser ProtocolParser MasterSlave Progress FileIterator Runtime Pipeline 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.19'; 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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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; 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 = '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"; } $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 # ########################################################################### # ########################################################################### # 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 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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 ? '%1$.'.$p.'f%2$s' : '%1$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 # ########################################################################### # ########################################################################### # QueryRewriter 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/QueryRewriter.pm # t/lib/QueryRewriter.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryRewriter; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; our $verbs = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT |UPDATE|DELETE|REPLACE|^SET|UNION|^START|^LOCK}xi; my $quote_re = qr/"(?:(?!(? [^()]+ ) # Non-parens without backtracking | (??{ $bal }) # Group with matching parens )* \) /x; my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/; # One-line comments my $mlc_re = qr#/\*[^!].*?\*/#sm; # But not /*!version */ my $vlc_re = qr#/\*.*?[0-9]+.*?\*/#sm; # For SHOW + /*!version */ my $vlc_rf = qr#^(?:SHOW).*?/\*![0-9]+(.*?)\*/#sm; # Variation for SHOW sub new { my ( $class, %args ) = @_; my $self = { %args }; return bless $self, $class; } sub strip_comments { my ( $self, $query ) = @_; return unless $query; $query =~ s/$mlc_re//go; $query =~ s/$olc_re//go; if ( $query =~ m/$vlc_rf/i ) { # contains show + version my $qualifier = $1 || ''; $query =~ s/$vlc_re/$qualifier/go; } return $query; } sub shorten { my ( $self, $query, $length ) = @_; $query =~ s{ \A( (?:INSERT|REPLACE) (?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)? (?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\) ) \s*,\s*\(.*?(ON\s+DUPLICATE|\Z)} {$1 /*... omitted ...*/$2}xsi; return $query unless $query =~ m/IN\s*\(\s*(?!select)/i; my $last_length = 0; my $query_length = length($query); while ( $length > 0 && $query_length > $length && $query_length < ( $last_length || $query_length + 1 ) ) { $last_length = $query_length; $query =~ s{ (\bIN\s*\() # The opening of an IN list ([^\)]+) # Contents of the list, assuming no item contains paren (?=\)) # Close of the list } { $1 . __shorten($2) }gexsi; } return $query; } sub __shorten { my ( $snippet ) = @_; my @vals = split(/,/, $snippet); return $snippet unless @vals > 20; my @keep = splice(@vals, 0, 20); # Remove and save the first 20 items return join(',', @keep) . "/*... omitted " . scalar(@vals) . " items ...*/"; } sub fingerprint { my ( $self, $query ) = @_; $query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query && return 'mysqldump'; $query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/# # pt-table-checksum, etc query && return 'percona-toolkit'; $query =~ m/\Aadministrator command: / && return $query; $query =~ m/\A\s*(call\s+\S+)\(/i && return lc($1); # Warning! $1 used, be careful. if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)?\s+INTO.+?VALUES\s*\(.*?\))\s*,\s*\(/is ) { $query = $beginning; # Shorten multi-value INSERT statements ASAP } $query =~ s/$mlc_re//go; $query =~ s/$olc_re//go; $query =~ s/\Ause \S+\Z/use ?/i # Abstract the DB in USE && return $query; $query =~ s/\\["']//g; # quoted strings $query =~ s/".*?"/?/sg; # quoted strings $query =~ s/'.*?'/?/sg; # quoted strings $query =~ s/\bfalse\b|\btrue\b/?/isg; # boolean values if ( $self->{match_md5_checksums} ) { $query =~ s/([._-])[a-f0-9]{32}/$1?/g; } if ( !$self->{match_embedded_numbers} ) { $query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g; } else { $query =~ s/\b[0-9+-][0-9a-f.xb+-]*/?/g; } if ( $self->{match_md5_checksums} ) { $query =~ s/[xb+-]\?/?/g; } else { $query =~ s/[xb.+-]\?/?/g; } $query =~ s/\A\s+//; # Chop off leading whitespace chomp $query; # Kill trailing whitespace $query =~ tr[ \n\t\r\f][ ]s; # Collapse whitespace $query = lc $query; $query =~ s/\bnull\b/?/g; # Get rid of NULLs $query =~ s{ # Collapse IN and VALUES lists \b(in|values?)(?:[\s,]*\([\s?,]*\))+ } {$1(?+)}gx; $query =~ s{ # Collapse UNION \b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+ } {$1 /*repeat$2*/}xg; $query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT if ( $query =~ m/\bORDER BY /gi ) { # Find, anchor on ORDER BY clause 1 while $query =~ s/\G(.+?)\s+ASC/$1/gi && pos $query; } return $query; } sub distill_verbs { my ( $self, $query ) = @_; $query =~ m/\A\s*call\s+(\S+)\(/i && return "CALL $1"; $query =~ m/\A\s*use\s+/ && return "USE"; $query =~ m/\A\s*UNLOCK TABLES/i && return "UNLOCK"; $query =~ m/\A\s*xa\s+(\S+)/i && return "XA_$1"; if ( $query =~ m/\A\s*LOAD/i ) { my ($tbl) = $query =~ m/INTO TABLE\s+(\S+)/i; $tbl ||= ''; $tbl =~ s/`//g; return "LOAD DATA $tbl"; } if ( $query =~ m/\Aadministrator command:/ ) { $query =~ s/administrator command:/ADMIN/; $query = uc $query; return $query; } $query = $self->strip_comments($query); if ( $query =~ m/\A\s*SHOW\s+/i ) { PTDEBUG && _d($query); $query = uc $query; $query =~ s/\s+(?:SESSION|FULL|STORAGE|ENGINE)\b/ /g; $query =~ s/\s+COUNT[^)]+\)//g; $query =~ s/\s+(?:FOR|FROM|LIKE|WHERE|LIMIT|IN)\b.+//ms; $query =~ s/\A(SHOW(?:\s+\S+){1,2}).*\Z/$1/s; $query =~ s/\s+/ /g; PTDEBUG && _d($query); return $query; } eval $QueryParser::data_def_stmts; eval $QueryParser::tbl_ident; my ( $dds ) = $query =~ /^\s*($QueryParser::data_def_stmts)\b/i; if ( $dds) { $query =~ s/\s+IF(?:\s+NOT)?\s+EXISTS/ /i; my ( $obj ) = $query =~ m/$dds.+(DATABASE|TABLE)\b/i; $obj = uc $obj if $obj; PTDEBUG && _d('Data def statment:', $dds, 'obj:', $obj); my ($db_or_tbl) = $query =~ m/(?:TABLE|DATABASE)\s+($QueryParser::tbl_ident)(\s+.*)?/i; PTDEBUG && _d('Matches db or table:', $db_or_tbl); return uc($dds . ($obj ? " $obj" : '')), $db_or_tbl; } my @verbs = $query =~ m/\b($verbs)\b/gio; @verbs = do { my $last = ''; grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs; }; if ( ($verbs[0] || '') eq 'SELECT' && @verbs > 1 ) { PTDEBUG && _d("False-positive verbs after SELECT:", @verbs[1..$#verbs]); my $union = grep { $_ eq 'UNION' } @verbs; @verbs = $union ? qw(SELECT UNION) : qw(SELECT); } my $verb_str = join(q{ }, @verbs); return $verb_str; } sub __distill_tables { my ( $self, $query, $table, %args ) = @_; my $qp = $args{QueryParser} || $self->{QueryParser}; die "I need a QueryParser argument" unless $qp; my @tables = map { $_ =~ s/`//g; $_ =~ s/(_?)[0-9]+/$1?/g; $_; } grep { defined $_ } $qp->get_tables($query); push @tables, $table if $table; @tables = do { my $last = ''; grep { my $pass = $_ ne $last; $last = $_; $pass } @tables; }; return @tables; } sub distill { my ( $self, $query, %args ) = @_; if ( $args{generic} ) { my ($cmd, $arg) = $query =~ m/^(\S+)\s+(\S+)/; return '' unless $cmd; $query = (uc $cmd) . ($arg ? " $arg" : ''); } else { my ($verbs, $table) = $self->distill_verbs($query, %args); if ( $verbs && $verbs =~ m/^SHOW/ ) { my %alias_for = qw( SCHEMA DATABASE KEYS INDEX INDEXES INDEX ); map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for; $query = $verbs; } elsif ( $verbs && $verbs =~ m/^LOAD DATA/ ) { return $verbs; } else { my @tables = $self->__distill_tables($query, $table, %args); $query = join(q{ }, $verbs, @tables); } } if ( $args{trf} ) { $query = $args{trf}->($query, %args); } return $query; } sub convert_to_select { my ( $self, $query ) = @_; return unless $query; return if $query =~ m/=\s*\(\s*SELECT /i; $query =~ s{ \A.*? update(?:\s+(?:low_priority|ignore))?\s+(.*?) \s+set\b(.*?) (?:\s*where\b(.*?))? (limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)? \Z } {__update_to_select($1, $2, $3, $4)}exsi || $query =~ s{ \A.*? (?:insert(?:\s+ignore)?|replace)\s+ .*?\binto\b(.*?)\(([^\)]+)\)\s* values?\s*(\(.*?\))\s* (?:\blimit\b|on\s+duplicate\s+key.*)?\s* \Z } {__insert_to_select($1, $2, $3)}exsi || $query =~ s{ \A.*? (?:insert(?:\s+ignore)?|replace)\s+ (?:.*?\binto)\b(.*?)\s* set\s+(.*?)\s* (?:\blimit\b|on\s+duplicate\s+key.*)?\s* \Z } {__insert_to_select_with_set($1, $2)}exsi || $query =~ s{ \A.*? delete\s+(.*?) \bfrom\b(.*) \Z } {__delete_to_select($1, $2)}exsi; $query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si; $query =~ s/\A.*?(?=\bSELECT\s*\b)//ism; return $query; } sub convert_select_list { my ( $self, $query ) = @_; $query =~ s{ \A\s*select(.*?)\bfrom\b } {$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi; return $query; } sub __delete_to_select { my ( $delete, $join ) = @_; if ( $join =~ m/\bjoin\b/ ) { return "select 1 from $join"; } return "select * from $join"; } sub __insert_to_select { my ( $tbl, $cols, $vals ) = @_; PTDEBUG && _d('Args:', @_); my @cols = split(/,/, $cols); PTDEBUG && _d('Cols:', @cols); $vals =~ s/^\(|\)$//g; # Strip leading/trailing parens my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g; PTDEBUG && _d('Vals:', @vals); if ( @cols == @vals ) { return "select * from $tbl where " . join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols)); } else { return "select * from $tbl limit 1"; } } sub __insert_to_select_with_set { my ( $from, $set ) = @_; $set =~ s/,/ and /g; return "select * from $from where $set "; } sub __update_to_select { my ( $from, $set, $where, $limit ) = @_; return "select $set from $from " . ( $where ? "where $where" : '' ) . ( $limit ? " $limit " : '' ); } sub wrap_in_derived { my ( $self, $query ) = @_; return unless $query; return $query =~ m/\A\s*select/i ? "select 1 from ($query) as x limit 1" : $query; } 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 QueryRewriter package # ########################################################################### # ########################################################################### # Processlist 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/Processlist.pm # t/lib/Processlist.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package Processlist; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use Time::HiRes qw(time usleep); use List::Util qw(max); use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; use constant PTDEBUG => $ENV{PTDEBUG} || 0; use constant { ID => 0, USER => 1, HOST => 2, DB => 3, COMMAND => 4, TIME => 5, STATE => 6, INFO => 7, START => 8, # Calculated start time of statement ($start - TIME) ETIME => 9, # Exec time of SHOW PROCESSLIST (margin of error in START) FSEEN => 10, # First time ever seen PROFILE => 11, # Profile of individual STATE times }; sub new { my ( $class, %args ) = @_; foreach my $arg ( qw(MasterSlave) ) { die "I need a $arg argument" unless $args{$arg}; } my $self = { %args, polls => 0, last_poll => 0, active_cxn => {}, # keyed off ID event_cache => [], _reasons_for_matching => {}, }; return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(code); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($code) = @args{@required_args}; if ( @{$self->{event_cache}} ) { PTDEBUG && _d("Returning cached event"); return shift @{$self->{event_cache}}; } if ( $self->{interval} && $self->{polls} ) { PTDEBUG && _d("Sleeping between polls"); usleep($self->{interval}); } PTDEBUG && _d("Polling PROCESSLIST"); my ($time, $etime) = @args{qw(time etime)}; my $start = $etime ? 0 : time; # don't need start if etime given my $rows = $code->(); if ( !$rows ) { warn "Processlist callback did not return an arrayref"; return; } $time = time unless $time; $etime = $time - $start unless $etime; $self->{polls}++; PTDEBUG && _d('Rows:', ($rows ? scalar @$rows : 0), 'in', $etime, 'seconds'); my $active_cxn = $self->{active_cxn}; my $curr_cxn = {}; my @new_cxn = (); CURRENTLY_ACTIVE_CXN: foreach my $curr ( @$rows ) { $curr_cxn->{$curr->[ID]} = $curr; my $query_start = $time - ($curr->[TIME] || 0); if ( $active_cxn->{$curr->[ID]} ) { PTDEBUG && _d('Checking existing cxn', $curr->[ID]); my $prev = $active_cxn->{$curr->[ID]}; # previous state of cxn my $new_query = 0; my $fudge = ($curr->[TIME] || 0) =~ m/\D/ ? 0.001 : 1; # micro-t? if ( $prev->[INFO] ) { if ( !$curr->[INFO] || $prev->[INFO] ne $curr->[INFO] ) { PTDEBUG && _d('Info is different; new query'); $new_query = 1; } elsif ( defined $curr->[TIME] && $curr->[TIME] < $prev->[TIME] ) { PTDEBUG && _d('Time is less than previous; new query'); $new_query = 1; } elsif ( $curr->[INFO] && defined $curr->[TIME] && $query_start - $etime - $prev->[START] > $fudge) { my $ms = $self->{MasterSlave}; my $is_repl_thread = $ms->is_replication_thread({ Command => $curr->[COMMAND], User => $curr->[USER], State => $curr->[STATE], Id => $curr->[ID]}); if ( $is_repl_thread ) { PTDEBUG && _d(q{Query has restarted but it's a replication thread, ignoring}); } else { PTDEBUG && _d('Query restarted; new query', $query_start, $etime, $prev->[START], $fudge); $new_query = 1; } } if ( $new_query ) { $self->_update_profile($prev, $curr, $time); push @{$self->{event_cache}}, $self->make_event($prev, $time); } } if ( $curr->[INFO] ) { if ( $prev->[INFO] && !$new_query ) { PTDEBUG && _d("Query on cxn", $curr->[ID], "hasn't changed"); $self->_update_profile($prev, $curr, $time); } else { PTDEBUG && _d('Saving new query, state', $curr->[STATE]); push @new_cxn, [ @{$curr}[0..7], # proc info int($query_start), # START $etime, # ETIME $time, # FSEEN { ($curr->[STATE] || "") => 0 }, # PROFILE ]; } } } else { PTDEBUG && _d('New cxn', $curr->[ID]); if ( $curr->[INFO] && defined $curr->[TIME] ) { PTDEBUG && _d('Saving query of new cxn, state', $curr->[STATE]); push @new_cxn, [ @{$curr}[0..7], # proc info int($query_start), # START $etime, # ETIME $time, # FSEEN { ($curr->[STATE] || "") => 0 }, # PROFILE ]; } } } # CURRENTLY_ACTIVE_CXN PREVIOUSLY_ACTIVE_CXN: foreach my $prev ( values %$active_cxn ) { if ( !$curr_cxn->{$prev->[ID]} ) { PTDEBUG && _d('cxn', $prev->[ID], 'ended'); push @{$self->{event_cache}}, $self->make_event($prev, $time); delete $active_cxn->{$prev->[ID]}; } elsif ( ($curr_cxn->{$prev->[ID]}->[COMMAND] || "") eq 'Sleep' || !$curr_cxn->{$prev->[ID]}->[STATE] || !$curr_cxn->{$prev->[ID]}->[INFO] ) { PTDEBUG && _d('cxn', $prev->[ID], 'became idle'); delete $active_cxn->{$prev->[ID]}; } } map { $active_cxn->{$_->[ID]} = $_; } @new_cxn; $self->{last_poll} = $time; my $event = shift @{$self->{event_cache}}; PTDEBUG && _d(scalar @{$self->{event_cache}}, "events in cache"); return $event; } sub make_event { my ( $self, $row, $time ) = @_; my $observed_time = $time - $row->[FSEEN]; my $Query_time = max($row->[TIME], $observed_time); my $event = { id => $row->[ID], db => $row->[DB], user => $row->[USER], host => $row->[HOST], arg => $row->[INFO], bytes => length($row->[INFO]), ts => Transformers::ts($row->[START] + $row->[TIME]), # Query END time Query_time => $Query_time, Lock_time => $row->[PROFILE]->{Locked} || 0, }; PTDEBUG && _d('Properties of event:', Dumper($event)); return $event; } sub _get_active_cxn { my ( $self ) = @_; PTDEBUG && _d("Active cxn:", Dumper($self->{active_cxn})); return $self->{active_cxn}; } sub _update_profile { my ( $self, $prev, $curr, $time ) = @_; return unless $prev && $curr; my $time_elapsed = $time - $self->{last_poll}; if ( ($prev->[STATE] || "") eq ($curr->[STATE] || "") ) { PTDEBUG && _d("Query is still in", $curr->[STATE], "state"); $prev->[PROFILE]->{$prev->[STATE] || ""} += $time_elapsed; } else { PTDEBUG && _d("Query changed from state", $prev->[STATE], "to", $curr->[STATE]); my $half_time = ($time_elapsed || 0) / 2; $prev->[PROFILE]->{$prev->[STATE] || ""} += $half_time; $prev->[STATE] = $curr->[STATE]; $prev->[PROFILE]->{$curr->[STATE] || ""} = $half_time; } return; } sub find { my ( $self, $proclist, %find_spec ) = @_; PTDEBUG && _d('find specs:', Dumper(\%find_spec)); my $ms = $self->{MasterSlave}; my @matches; QUERY: foreach my $query ( @$proclist ) { PTDEBUG && _d('Checking query', Dumper($query)); my $matched = 0; if ( !$find_spec{replication_threads} && $ms->is_replication_thread($query) ) { PTDEBUG && _d('Skipping replication thread'); next QUERY; } if ( $find_spec{busy_time} && ($query->{Command} || '') eq 'Query' ) { next QUERY unless defined($query->{Time}); if ( $query->{Time} < $find_spec{busy_time} ) { PTDEBUG && _d("Query isn't running long enough"); next QUERY; } my $reason = 'Exceeds busy time'; PTDEBUG && _d($reason); push @{$self->{_reasons_for_matching}->{$query} ||= []}, $reason; $matched++; } if ( $find_spec{idle_time} && ($query->{Command} || '') eq 'Sleep' ) { next QUERY unless defined($query->{Time}); if ( $query->{Time} < $find_spec{idle_time} ) { PTDEBUG && _d("Query isn't idle long enough"); next QUERY; } my $reason = 'Exceeds idle time'; PTDEBUG && _d($reason); push @{$self->{_reasons_for_matching}->{$query} ||= []}, $reason; $matched++; } PROPERTY: foreach my $property ( qw(Id User Host db State Command Info) ) { my $filter = "_find_match_$property"; if ( defined $find_spec{ignore}->{$property} && $self->$filter($query, $find_spec{ignore}->{$property}) ) { PTDEBUG && _d('Query matches ignore', $property, 'spec'); next QUERY; } if ( defined $find_spec{match}->{$property} ) { if ( !$self->$filter($query, $find_spec{match}->{$property}) ) { PTDEBUG && _d('Query does not match', $property, 'spec'); next QUERY; } my $reason = 'Query matches ' . $property . ' spec'; PTDEBUG && _d($reason); push @{$self->{_reasons_for_matching}->{$query} ||= []}, $reason; $matched++; } } if ( $matched || $find_spec{all} ) { PTDEBUG && _d("Query matched one or more specs, adding"); push @matches, $query; next QUERY; } PTDEBUG && _d('Query does not match any specs, ignoring'); } # QUERY return @matches; } sub _find_match_Id { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Id} && $query->{Id} == $property; } sub _find_match_User { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{User} && $query->{User} =~ m/$property/; } sub _find_match_Host { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Host} && $query->{Host} =~ m/$property/; } sub _find_match_db { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{db} && $query->{db} =~ m/$property/; } sub _find_match_State { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{State} && $query->{State} =~ m/$property/; } sub _find_match_Command { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Command} && $query->{Command} =~ m/$property/; } sub _find_match_Info { my ( $self, $query, $property ) = @_; return defined $property && defined $query->{Info} && $query->{Info} =~ m/$property/; } 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 Processlist package # ########################################################################### # ########################################################################### # TcpdumpParser 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/TcpdumpParser.pm # t/lib/TcpdumpParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package TcpdumpParser; 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 $self = {}; return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(next_event tell); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($next_event, $tell) = @args{@required_args}; local $INPUT_RECORD_SEPARATOR = "\n20"; my $pos_in_log = $tell->(); while ( defined(my $raw_packet = $next_event->()) ) { next if $raw_packet =~ m/^$/; # issue 564 $pos_in_log -= 1 if $pos_in_log; $raw_packet =~ s/\n20\Z//; $raw_packet = "20$raw_packet" unless $raw_packet =~ m/\A20/; $raw_packet =~ s/0x0000:.+?(450.) /0x0000: $1 /; my $packet = $self->_parse_packet($raw_packet); $packet->{pos_in_log} = $pos_in_log; $packet->{raw_packet} = $raw_packet; $args{stats}->{events_read}++ if $args{stats}; return $packet; } $args{oktorun}->(0) if $args{oktorun}; return; } sub _parse_packet { my ( $self, $packet ) = @_; die "I need a packet" unless $packet; my ( $ts, $source, $dest ) = $packet =~ m/\A(\S+ \S+).*? IP .*?(\S+) > (\S+):/; my ( $src_host, $src_port ) = $source =~ m/((?:\d+\.){3}\d+)\.(\w+)/; my ( $dst_host, $dst_port ) = $dest =~ m/((?:\d+\.){3}\d+)\.(\w+)/; $src_port = $self->port_number($src_port); $dst_port = $self->port_number($dst_port); my $hex = qr/[0-9a-f]/; (my $data = join('', $packet =~ m/\s+0x$hex+:\s((?:\s$hex{2,4})+)/go)) =~ s/\s+//g; my $ip_hlen = hex(substr($data, 1, 1)); # Num of 32-bit words in header. my $ip_plen = hex(substr($data, 4, 4)); # Num of BYTES in IPv4 datagram. my $complete = length($data) == 2 * $ip_plen ? 1 : 0; my $tcp_hlen = hex(substr($data, ($ip_hlen + 3) * 8, 1)); my $seq = hex(substr($data, ($ip_hlen + 1) * 8, 8)); my $ack = hex(substr($data, ($ip_hlen + 2) * 8, 8)); my $flags = hex(substr($data, (($ip_hlen + 3) * 8) + 2, 2)); $data = substr($data, ($ip_hlen + $tcp_hlen) * 8); my $pkt = { ts => $ts, seq => $seq, ack => $ack, fin => $flags & 0x01, syn => $flags & 0x02, rst => $flags & 0x04, src_host => $src_host, src_port => $src_port, dst_host => $dst_host, dst_port => $dst_port, complete => $complete, ip_hlen => $ip_hlen, tcp_hlen => $tcp_hlen, dgram_len => $ip_plen, data_len => $ip_plen - (($ip_hlen + $tcp_hlen) * 4), data => $data ? substr($data, 0, 10).(length $data > 10 ? '...' : '') : '', }; PTDEBUG && _d('packet:', Dumper($pkt)); $pkt->{data} = $data; return $pkt; } sub port_number { my ( $self, $port ) = @_; return unless $port; return $port eq 'mysql' ? 3306 : $port; } 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 TcpdumpParser package # ########################################################################### # ########################################################################### # MySQLProtocolParser 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/MySQLProtocolParser.pm # t/lib/MySQLProtocolParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package MySQLProtocolParser; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; eval { require IO::Uncompress::Inflate; # yum: perl-IO-Compress-Zlib IO::Uncompress::Inflate->import(qw(inflate $InflateError)); }; use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; BEGIN { our @ISA = 'ProtocolParser'; } use constant { COM_SLEEP => '00', COM_QUIT => '01', COM_INIT_DB => '02', COM_QUERY => '03', COM_FIELD_LIST => '04', COM_CREATE_DB => '05', COM_DROP_DB => '06', COM_REFRESH => '07', COM_SHUTDOWN => '08', COM_STATISTICS => '09', COM_PROCESS_INFO => '0a', COM_CONNECT => '0b', COM_PROCESS_KILL => '0c', COM_DEBUG => '0d', COM_PING => '0e', COM_TIME => '0f', COM_DELAYED_INSERT => '10', COM_CHANGE_USER => '11', COM_BINLOG_DUMP => '12', COM_TABLE_DUMP => '13', COM_CONNECT_OUT => '14', COM_REGISTER_SLAVE => '15', COM_STMT_PREPARE => '16', COM_STMT_EXECUTE => '17', COM_STMT_SEND_LONG_DATA => '18', COM_STMT_CLOSE => '19', COM_STMT_RESET => '1a', COM_SET_OPTION => '1b', COM_STMT_FETCH => '1c', SERVER_QUERY_NO_GOOD_INDEX_USED => 16, SERVER_QUERY_NO_INDEX_USED => 32, }; my %com_for = ( '00' => 'COM_SLEEP', '01' => 'COM_QUIT', '02' => 'COM_INIT_DB', '03' => 'COM_QUERY', '04' => 'COM_FIELD_LIST', '05' => 'COM_CREATE_DB', '06' => 'COM_DROP_DB', '07' => 'COM_REFRESH', '08' => 'COM_SHUTDOWN', '09' => 'COM_STATISTICS', '0a' => 'COM_PROCESS_INFO', '0b' => 'COM_CONNECT', '0c' => 'COM_PROCESS_KILL', '0d' => 'COM_DEBUG', '0e' => 'COM_PING', '0f' => 'COM_TIME', '10' => 'COM_DELAYED_INSERT', '11' => 'COM_CHANGE_USER', '12' => 'COM_BINLOG_DUMP', '13' => 'COM_TABLE_DUMP', '14' => 'COM_CONNECT_OUT', '15' => 'COM_REGISTER_SLAVE', '16' => 'COM_STMT_PREPARE', '17' => 'COM_STMT_EXECUTE', '18' => 'COM_STMT_SEND_LONG_DATA', '19' => 'COM_STMT_CLOSE', '1a' => 'COM_STMT_RESET', '1b' => 'COM_SET_OPTION', '1c' => 'COM_STMT_FETCH', ); my %flag_for = ( 'CLIENT_LONG_PASSWORD' => 1, # new more secure passwords 'CLIENT_FOUND_ROWS' => 2, # Found instead of affected rows 'CLIENT_LONG_FLAG' => 4, # Get all column flags 'CLIENT_CONNECT_WITH_DB' => 8, # One can specify db on connect 'CLIENT_NO_SCHEMA' => 16, # Don't allow database.table.column 'CLIENT_COMPRESS' => 32, # Can use compression protocol 'CLIENT_ODBC' => 64, # Odbc client 'CLIENT_LOCAL_FILES' => 128, # Can use LOAD DATA LOCAL 'CLIENT_IGNORE_SPACE' => 256, # Ignore spaces before '(' 'CLIENT_PROTOCOL_41' => 512, # New 4.1 protocol 'CLIENT_INTERACTIVE' => 1024, # This is an interactive client 'CLIENT_SSL' => 2048, # Switch to SSL after handshake 'CLIENT_IGNORE_SIGPIPE' => 4096, # IGNORE sigpipes 'CLIENT_TRANSACTIONS' => 8192, # Client knows about transactions 'CLIENT_RESERVED' => 16384, # Old flag for 4.1 protocol 'CLIENT_SECURE_CONNECTION' => 32768, # New 4.1 authentication 'CLIENT_MULTI_STATEMENTS' => 65536, # Enable/disable multi-stmt support 'CLIENT_MULTI_RESULTS' => 131072, # Enable/disable multi-results ); use constant { MYSQL_TYPE_DECIMAL => 0, MYSQL_TYPE_TINY => 1, MYSQL_TYPE_SHORT => 2, MYSQL_TYPE_LONG => 3, MYSQL_TYPE_FLOAT => 4, MYSQL_TYPE_DOUBLE => 5, MYSQL_TYPE_NULL => 6, MYSQL_TYPE_TIMESTAMP => 7, MYSQL_TYPE_LONGLONG => 8, MYSQL_TYPE_INT24 => 9, MYSQL_TYPE_DATE => 10, MYSQL_TYPE_TIME => 11, MYSQL_TYPE_DATETIME => 12, MYSQL_TYPE_YEAR => 13, MYSQL_TYPE_NEWDATE => 14, MYSQL_TYPE_VARCHAR => 15, MYSQL_TYPE_BIT => 16, MYSQL_TYPE_NEWDECIMAL => 246, MYSQL_TYPE_ENUM => 247, MYSQL_TYPE_SET => 248, MYSQL_TYPE_TINY_BLOB => 249, MYSQL_TYPE_MEDIUM_BLOB => 250, MYSQL_TYPE_LONG_BLOB => 251, MYSQL_TYPE_BLOB => 252, MYSQL_TYPE_VAR_STRING => 253, MYSQL_TYPE_STRING => 254, MYSQL_TYPE_GEOMETRY => 255, }; my %type_for = ( 0 => 'MYSQL_TYPE_DECIMAL', 1 => 'MYSQL_TYPE_TINY', 2 => 'MYSQL_TYPE_SHORT', 3 => 'MYSQL_TYPE_LONG', 4 => 'MYSQL_TYPE_FLOAT', 5 => 'MYSQL_TYPE_DOUBLE', 6 => 'MYSQL_TYPE_NULL', 7 => 'MYSQL_TYPE_TIMESTAMP', 8 => 'MYSQL_TYPE_LONGLONG', 9 => 'MYSQL_TYPE_INT24', 10 => 'MYSQL_TYPE_DATE', 11 => 'MYSQL_TYPE_TIME', 12 => 'MYSQL_TYPE_DATETIME', 13 => 'MYSQL_TYPE_YEAR', 14 => 'MYSQL_TYPE_NEWDATE', 15 => 'MYSQL_TYPE_VARCHAR', 16 => 'MYSQL_TYPE_BIT', 246 => 'MYSQL_TYPE_NEWDECIMAL', 247 => 'MYSQL_TYPE_ENUM', 248 => 'MYSQL_TYPE_SET', 249 => 'MYSQL_TYPE_TINY_BLOB', 250 => 'MYSQL_TYPE_MEDIUM_BLOB', 251 => 'MYSQL_TYPE_LONG_BLOB', 252 => 'MYSQL_TYPE_BLOB', 253 => 'MYSQL_TYPE_VAR_STRING', 254 => 'MYSQL_TYPE_STRING', 255 => 'MYSQL_TYPE_GEOMETRY', ); my %unpack_type = ( MYSQL_TYPE_NULL => sub { return 'NULL', 0; }, MYSQL_TYPE_TINY => sub { return to_num(@_, 1), 1; }, MySQL_TYPE_SHORT => sub { return to_num(@_, 2), 2; }, MYSQL_TYPE_LONG => sub { return to_num(@_, 4), 4; }, MYSQL_TYPE_LONGLONG => sub { return to_num(@_, 8), 8; }, MYSQL_TYPE_DOUBLE => sub { return to_double(@_), 8; }, MYSQL_TYPE_VARCHAR => \&unpack_string, MYSQL_TYPE_VAR_STRING => \&unpack_string, MYSQL_TYPE_STRING => \&unpack_string, ); sub new { my ( $class, %args ) = @_; my $self = { server => $args{server}, port => $args{port} || '3306', version => '41', # MySQL proto version; not used yet sessions => {}, o => $args{o}, fake_thread_id => 2**32, # see _make_event() null_event => $args{null_event}, }; PTDEBUG && $self->{server} && _d('Watching only server', $self->{server}); return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(event); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my $packet = @args{@required_args}; my $src_host = "$packet->{src_host}:$packet->{src_port}"; my $dst_host = "$packet->{dst_host}:$packet->{dst_port}"; if ( my $server = $self->{server} ) { # Watch only the given server. $server .= ":$self->{port}"; if ( $src_host ne $server && $dst_host ne $server ) { PTDEBUG && _d('Packet is not to or from', $server); return $self->{null_event}; } } my $packet_from; my $client; if ( $src_host =~ m/:$self->{port}$/ ) { $packet_from = 'server'; $client = $dst_host; } elsif ( $dst_host =~ m/:$self->{port}$/ ) { $packet_from = 'client'; $client = $src_host; } else { PTDEBUG && _d('Packet is not to or from a MySQL server'); return $self->{null_event}; } PTDEBUG && _d('Client', $client); my $packetno = -1; if ( $packet->{data_len} >= 5 ) { $packetno = to_num(substr($packet->{data}, 6, 2)); } if ( !exists $self->{sessions}->{$client} ) { if ( $packet->{syn} ) { PTDEBUG && _d('New session (SYN)'); } elsif ( $packetno == 0 ) { PTDEBUG && _d('New session (packetno 0)'); } else { PTDEBUG && _d('Ignoring mid-stream', $packet_from, 'data,', 'packetno', $packetno); return $self->{null_event}; } $self->{sessions}->{$client} = { client => $client, ts => $packet->{ts}, state => undef, compress => undef, raw_packets => [], buff => '', sths => {}, attribs => {}, n_queries => 0, }; } my $session = $self->{sessions}->{$client}; PTDEBUG && _d('Client state:', $session->{state}); push @{$session->{raw_packets}}, $packet->{raw_packet}; if ( $packet->{syn} && ($session->{n_queries} > 0 || $session->{state}) ) { PTDEBUG && _d('Client port reuse and last session did not quit'); $self->fail_session($session, 'client port reuse and last session did not quit'); return $self->parse_event(%args); } if ( $packet->{data_len} == 0 ) { PTDEBUG && _d('TCP control:', map { uc $_ } grep { $packet->{$_} } qw(syn ack fin rst)); if ( $packet->{'fin'} && ($session->{state} || '') eq 'server_handshake' ) { PTDEBUG && _d('Client aborted connection'); my $event = { cmd => 'Admin', arg => 'administrator command: Connect', ts => $packet->{ts}, }; $session->{attribs}->{Error_msg} = 'Client closed connection during handshake'; $event = $self->_make_event($event, $packet, $session); delete $self->{sessions}->{$session->{client}}; return $event; } return $self->{null_event}; } if ( $session->{compress} ) { return unless $self->uncompress_packet($packet, $session); } if ( $session->{buff} && $packet_from eq 'client' ) { $session->{buff} .= $packet->{data}; $packet->{data} = $session->{buff}; $session->{buff_left} -= $packet->{data_len}; $packet->{mysql_data_len} = $session->{mysql_data_len}; $packet->{number} = $session->{number}; PTDEBUG && _d('Appending data to buff; expecting', $session->{buff_left}, 'more bytes'); } else { eval { remove_mysql_header($packet); }; if ( $EVAL_ERROR ) { PTDEBUG && _d('remove_mysql_header() failed; failing session'); $session->{EVAL_ERROR} = $EVAL_ERROR; $self->fail_session($session, 'remove_mysql_header() failed'); return $self->{null_event}; } } my $event; if ( $packet_from eq 'server' ) { $event = $self->_packet_from_server($packet, $session, $args{misc}); } elsif ( $packet_from eq 'client' ) { if ( $session->{buff} ) { if ( $session->{buff_left} <= 0 ) { PTDEBUG && _d('Data is complete'); $self->_delete_buff($session); } else { return $self->{null_event}; # waiting for more data; buff_left was reported earlier } } elsif ( $packet->{mysql_data_len} > ($packet->{data_len} - 4) ) { if ( $session->{cmd} && ($session->{state} || '') eq 'awaiting_reply' ) { PTDEBUG && _d('No server OK to previous command (frag)'); $self->fail_session($session, 'no server OK to previous command'); $packet->{data} = $packet->{mysql_hdr} . $packet->{data}; return $self->parse_event(%args); } $session->{buff} = $packet->{data}; $session->{mysql_data_len} = $packet->{mysql_data_len}; $session->{number} = $packet->{number}; $session->{buff_left} ||= $packet->{mysql_data_len} - ($packet->{data_len} - 4); PTDEBUG && _d('Data not complete; expecting', $session->{buff_left}, 'more bytes'); return $self->{null_event}; } if ( $session->{cmd} && ($session->{state} || '') eq 'awaiting_reply' ) { PTDEBUG && _d('No server OK to previous command'); $self->fail_session($session, 'no server OK to previous command'); $packet->{data} = $packet->{mysql_hdr} . $packet->{data}; return $self->parse_event(%args); } $event = $self->_packet_from_client($packet, $session, $args{misc}); } else { die 'Packet origin unknown'; } PTDEBUG && _d('Done parsing packet; client state:', $session->{state}); if ( $session->{closed} ) { delete $self->{sessions}->{$session->{client}}; PTDEBUG && _d('Session deleted'); } $args{stats}->{events_parsed}++ if $args{stats}; return $event || $self->{null_event}; } sub _packet_from_server { my ( $self, $packet, $session, $misc ) = @_; die "I need a packet" unless $packet; die "I need a session" unless $session; PTDEBUG && _d('Packet is from server; client state:', $session->{state}); if ( ($session->{server_seq} || '') eq $packet->{seq} ) { push @{ $session->{server_retransmissions} }, $packet->{seq}; PTDEBUG && _d('TCP retransmission'); return; } $session->{server_seq} = $packet->{seq}; my $data = $packet->{data}; my ( $first_byte ) = substr($data, 0, 2, ''); PTDEBUG && _d('First byte of packet:', $first_byte); if ( !$first_byte ) { $self->fail_session($session, 'no first byte'); return; } if ( !$session->{state} ) { if ( $first_byte eq '0a' && length $data >= 33 && $data =~ m/00{13}/ ) { my $handshake = parse_server_handshake_packet($data); if ( !$handshake ) { $self->fail_session($session, 'failed to parse server handshake'); return; } $session->{state} = 'server_handshake'; $session->{thread_id} = $handshake->{thread_id}; $session->{ts} = $packet->{ts} unless $session->{ts}; } elsif ( $session->{buff} ) { $self->fail_session($session, 'got server response before full buffer'); return; } else { PTDEBUG && _d('Ignoring mid-stream server response'); return; } } else { if ( $first_byte eq '00' ) { if ( ($session->{state} || '') eq 'client_auth' ) { $session->{compress} = $session->{will_compress}; delete $session->{will_compress}; PTDEBUG && $session->{compress} && _d('Packets will be compressed'); PTDEBUG && _d('Admin command: Connect'); return $self->_make_event( { cmd => 'Admin', arg => 'administrator command: Connect', ts => $packet->{ts}, # Events are timestamped when they end }, $packet, $session ); } elsif ( $session->{cmd} ) { my $com = $session->{cmd}->{cmd}; my $ok; if ( $com eq COM_STMT_PREPARE ) { PTDEBUG && _d('OK for prepared statement'); $ok = parse_ok_prepared_statement_packet($data); if ( !$ok ) { $self->fail_session($session, 'failed to parse OK prepared statement packet'); return; } my $sth_id = $ok->{sth_id}; $session->{attribs}->{Statement_id} = $sth_id; $session->{sths}->{$sth_id} = $ok; $session->{sths}->{$sth_id}->{statement} = $session->{cmd}->{arg}; } else { $ok = parse_ok_packet($data); if ( !$ok ) { $self->fail_session($session, 'failed to parse OK packet'); return; } } my $arg; if ( $com eq COM_QUERY || $com eq COM_STMT_EXECUTE || $com eq COM_STMT_RESET ) { $com = 'Query'; $arg = $session->{cmd}->{arg}; } elsif ( $com eq COM_STMT_PREPARE ) { $com = 'Query'; $arg = "PREPARE $session->{cmd}->{arg}"; } else { $arg = 'administrator command: ' . ucfirst(lc(substr($com_for{$com}, 4))); $com = 'Admin'; } return $self->_make_event( { cmd => $com, arg => $arg, ts => $packet->{ts}, Insert_id => $ok->{insert_id}, Warning_count => $ok->{warnings}, Rows_affected => $ok->{affected_rows}, }, $packet, $session ); } else { PTDEBUG && _d('Looks like an OK packet but session has no cmd'); } } elsif ( $first_byte eq 'ff' ) { my $error = parse_error_packet($data); if ( !$error ) { $self->fail_session($session, 'failed to parse error packet'); return; } my $event; if ( $session->{state} eq 'client_auth' || $session->{state} eq 'server_handshake' ) { PTDEBUG && _d('Connection failed'); $event = { cmd => 'Admin', arg => 'administrator command: Connect', ts => $packet->{ts}, Error_no => $error->{errno}, }; $session->{attribs}->{Error_msg} = $error->{message}; $session->{closed} = 1; # delete session when done return $self->_make_event($event, $packet, $session); } elsif ( $session->{cmd} ) { my $com = $session->{cmd}->{cmd}; my $arg; if ( $com eq COM_QUERY || $com eq COM_STMT_EXECUTE ) { $com = 'Query'; $arg = $session->{cmd}->{arg}; } else { $arg = 'administrator command: ' . ucfirst(lc(substr($com_for{$com}, 4))); $com = 'Admin'; } $event = { cmd => $com, arg => $arg, ts => $packet->{ts}, }; if ( $error->{errno} ) { $event->{Error_no} = $error->{errno}; } $session->{attribs}->{Error_msg} = $error->{message}; return $self->_make_event($event, $packet, $session); } else { PTDEBUG && _d('Looks like an error packet but client is not ' . 'authenticating and session has no cmd'); } } elsif ( $first_byte eq 'fe' && $packet->{mysql_data_len} < 9 ) { if ( $packet->{mysql_data_len} == 1 && $session->{state} eq 'client_auth' && $packet->{number} == 2 ) { PTDEBUG && _d('Server has old password table;', 'client will resend password using old algorithm'); $session->{state} = 'client_auth_resend'; } else { PTDEBUG && _d('Got an EOF packet'); $self->fail_session($session, 'got an unexpected EOF packet'); } } else { if ( $session->{cmd} ) { PTDEBUG && _d('Got a row/field/result packet'); my $com = $session->{cmd}->{cmd}; PTDEBUG && _d('Responding to client', $com_for{$com}); my $event = { ts => $packet->{ts} }; if ( $com eq COM_QUERY || $com eq COM_STMT_EXECUTE ) { $event->{cmd} = 'Query'; $event->{arg} = $session->{cmd}->{arg}; } else { $event->{arg} = 'administrator command: ' . ucfirst(lc(substr($com_for{$com}, 4))); $event->{cmd} = 'Admin'; } if ( $packet->{complete} ) { my ( $warning_count, $status_flags ) = $data =~ m/fe(.{4})(.{4})\Z/; if ( $warning_count ) { $event->{Warnings} = to_num($warning_count); my $flags = to_num($status_flags); # TODO set all flags? $event->{No_good_index_used} = $flags & SERVER_QUERY_NO_GOOD_INDEX_USED ? 1 : 0; $event->{No_index_used} = $flags & SERVER_QUERY_NO_INDEX_USED ? 1 : 0; } } return $self->_make_event($event, $packet, $session); } else { PTDEBUG && _d('Unknown in-stream server response'); } } } return; } sub _packet_from_client { my ( $self, $packet, $session, $misc ) = @_; die "I need a packet" unless $packet; die "I need a session" unless $session; PTDEBUG && _d('Packet is from client; state:', $session->{state}); if ( ($session->{client_seq} || '') eq $packet->{seq} ) { push @{ $session->{client_retransmissions} }, $packet->{seq}; PTDEBUG && _d('TCP retransmission'); return; } $session->{client_seq} = $packet->{seq}; my $data = $packet->{data}; my $ts = $packet->{ts}; if ( ($session->{state} || '') eq 'server_handshake' ) { PTDEBUG && _d('Expecting client authentication packet'); my $handshake = parse_client_handshake_packet($data); if ( !$handshake ) { $self->fail_session($session, 'failed to parse client handshake'); return; } $session->{state} = 'client_auth'; $session->{pos_in_log} = $packet->{pos_in_log}; $session->{user} = $handshake->{user}; $session->{db} = $handshake->{db}; $session->{will_compress} = $handshake->{flags}->{CLIENT_COMPRESS}; } elsif ( ($session->{state} || '') eq 'client_auth_resend' ) { PTDEBUG && _d('Client resending password using old algorithm'); $session->{state} = 'client_auth'; } elsif ( ($session->{state} || '') eq 'awaiting_reply' ) { my $arg = $session->{cmd}->{arg} ? substr($session->{cmd}->{arg}, 0, 50) : 'unknown'; PTDEBUG && _d('More data for previous command:', $arg, '...'); return; } else { if ( $packet->{number} != 0 ) { $self->fail_session($session, 'client cmd not packet 0'); return; } if ( !defined $session->{compress} ) { return unless $self->detect_compression($packet, $session); $data = $packet->{data}; } my $com = parse_com_packet($data, $packet->{mysql_data_len}); if ( !$com ) { $self->fail_session($session, 'failed to parse COM packet'); return; } if ( $com->{code} eq COM_STMT_EXECUTE ) { PTDEBUG && _d('Execute prepared statement'); my $exec = parse_execute_packet($com->{data}, $session->{sths}); if ( !$exec ) { PTDEBUG && _d('Failed to parse execute packet'); $session->{state} = undef; return; } $com->{data} = $exec->{arg}; $session->{attribs}->{Statement_id} = $exec->{sth_id}; } elsif ( $com->{code} eq COM_STMT_RESET ) { my $sth_id = get_sth_id($com->{data}); if ( !$sth_id ) { $self->fail_session($session, 'failed to parse prepared statement reset packet'); return; } $com->{data} = "RESET $sth_id"; $session->{attribs}->{Statement_id} = $sth_id; } $session->{state} = 'awaiting_reply'; $session->{pos_in_log} = $packet->{pos_in_log}; $session->{ts} = $ts; $session->{cmd} = { cmd => $com->{code}, arg => $com->{data}, }; if ( $com->{code} eq COM_QUIT ) { # Fire right away; will cleanup later. PTDEBUG && _d('Got a COM_QUIT'); $session->{closed} = 1; # delete session when done return $self->_make_event( { cmd => 'Admin', arg => 'administrator command: Quit', ts => $ts, }, $packet, $session ); } elsif ( $com->{code} eq COM_STMT_CLOSE ) { my $sth_id = get_sth_id($com->{data}); if ( !$sth_id ) { $self->fail_session($session, 'failed to parse prepared statement close packet'); return; } delete $session->{sths}->{$sth_id}; return $self->_make_event( { cmd => 'Query', arg => "DEALLOCATE PREPARE $sth_id", ts => $ts, }, $packet, $session ); } } return; } sub _make_event { my ( $self, $event, $packet, $session ) = @_; PTDEBUG && _d('Making event'); $session->{raw_packets} = []; $self->_delete_buff($session); if ( !$session->{thread_id} ) { PTDEBUG && _d('Giving session fake thread id', $self->{fake_thread_id}); $session->{thread_id} = $self->{fake_thread_id}++; } my ($host, $port) = $session->{client} =~ m/((?:\d+\.){3}\d+)\:(\w+)/; my $new_event = { cmd => $event->{cmd}, arg => $event->{arg}, bytes => length( $event->{arg} ), ts => tcp_timestamp( $event->{ts} ), host => $host, ip => $host, port => $port, db => $session->{db}, user => $session->{user}, Thread_id => $session->{thread_id}, pos_in_log => $session->{pos_in_log}, Query_time => timestamp_diff($session->{ts}, $packet->{ts}), Rows_affected => ($event->{Rows_affected} || 0), Warning_count => ($event->{Warning_count} || 0), No_good_index_used => ($event->{No_good_index_used} ? 'Yes' : 'No'), No_index_used => ($event->{No_index_used} ? 'Yes' : 'No'), }; @{$new_event}{keys %{$session->{attribs}}} = values %{$session->{attribs}}; foreach my $opt_attrib ( qw(Error_no) ) { if ( defined $event->{$opt_attrib} ) { $new_event->{$opt_attrib} = $event->{$opt_attrib}; } } PTDEBUG && _d('Properties of event:', Dumper($new_event)); delete $session->{cmd}; $session->{state} = undef; $session->{attribs} = {}; $session->{n_queries}++; $session->{server_retransmissions} = []; $session->{client_retransmissions} = []; return $new_event; } sub tcp_timestamp { my ( $ts ) = @_; $ts =~ s/^\d\d(\d\d)-(\d\d)-(\d\d)/$1$2$3/; return $ts; } sub timestamp_diff { my ( $start, $end ) = @_; my $sd = substr($start, 0, 11, ''); my $ed = substr($end, 0, 11, ''); my ( $sh, $sm, $ss ) = split(/:/, $start); my ( $eh, $em, $es ) = split(/:/, $end); my $esecs = ($eh * 3600 + $em * 60 + $es); my $ssecs = ($sh * 3600 + $sm * 60 + $ss); if ( $sd eq $ed ) { return sprintf '%.6f', $esecs - $ssecs; } else { # Assume only one day boundary has been crossed, no DST, etc return sprintf '%.6f', ( 86_400 - $ssecs ) + $esecs; } } sub to_string { my ( $data ) = @_; return pack('H*', $data); } sub unpack_string { my ( $data ) = @_; my $len = 0; my $encode_len = 0; ($data, $len, $encode_len) = decode_len($data); my $t = 'H' . ($len ? $len * 2 : '*'); $data = pack($t, $data); return "\"$data\"", $encode_len + $len; } sub decode_len { my ( $data ) = @_; return unless $data; my $first_byte = to_num(substr($data, 0, 2, '')); my $len; my $encode_len; if ( $first_byte <= 251 ) { $len = $first_byte; $encode_len = 1; } elsif ( $first_byte == 252 ) { $len = to_num(substr($data, 4, '')); $encode_len = 2; } elsif ( $first_byte == 253 ) { $len = to_num(substr($data, 6, '')); $encode_len = 3; } elsif ( $first_byte == 254 ) { $len = to_num(substr($data, 16, '')); $encode_len = 8; } else { PTDEBUG && _d('data:', $data, 'first byte:', $first_byte); die "Invalid length encoded byte: $first_byte"; } PTDEBUG && _d('len:', $len, 'encode len', $encode_len); return $data, $len, $encode_len; } sub to_num { my ( $str, $len ) = @_; if ( $len ) { $str = substr($str, 0, $len * 2); } my @bytes = $str =~ m/(..)/g; my $result = 0; foreach my $i ( 0 .. $#bytes ) { $result += hex($bytes[$i]) * (16 ** ($i * 2)); } return $result; } sub to_double { my ( $str ) = @_; return unpack('d', pack('H*', $str)); } sub get_lcb { my ( $string ) = @_; my $first_byte = hex(substr($$string, 0, 2, '')); if ( $first_byte < 251 ) { return $first_byte; } elsif ( $first_byte == 252 ) { return to_num(substr($$string, 0, 4, '')); } elsif ( $first_byte == 253 ) { return to_num(substr($$string, 0, 6, '')); } elsif ( $first_byte == 254 ) { return to_num(substr($$string, 0, 16, '')); } } sub parse_error_packet { my ( $data ) = @_; return unless $data; PTDEBUG && _d('ERROR data:', $data); if ( length $data < 16 ) { PTDEBUG && _d('Error packet is too short:', $data); return; } my $errno = to_num(substr($data, 0, 4)); my $marker = to_string(substr($data, 4, 2)); my $sqlstate = ''; my $message = ''; if ( $marker eq '#' ) { $sqlstate = to_string(substr($data, 6, 10)); $message = to_string(substr($data, 16)); } else { $marker = ''; $message = to_string(substr($data, 4)); } return unless $message; my $pkt = { errno => $errno, sqlstate => $marker . $sqlstate, message => $message, }; PTDEBUG && _d('Error packet:', Dumper($pkt)); return $pkt; } sub parse_ok_packet { my ( $data ) = @_; return unless $data; PTDEBUG && _d('OK data:', $data); if ( length $data < 12 ) { PTDEBUG && _d('OK packet is too short:', $data); return; } my $affected_rows = get_lcb(\$data); my $insert_id = get_lcb(\$data); my $status = to_num(substr($data, 0, 4, '')); my $warnings = to_num(substr($data, 0, 4, '')); my $message = to_string($data); my $pkt = { affected_rows => $affected_rows, insert_id => $insert_id, status => $status, warnings => $warnings, message => $message, }; PTDEBUG && _d('OK packet:', Dumper($pkt)); return $pkt; } sub parse_ok_prepared_statement_packet { my ( $data ) = @_; return unless $data; PTDEBUG && _d('OK prepared statement data:', $data); if ( length $data < 8 ) { PTDEBUG && _d('OK prepared statement packet is too short:', $data); return; } my $sth_id = to_num(substr($data, 0, 8, '')); my $num_cols = to_num(substr($data, 0, 4, '')); my $num_params = to_num(substr($data, 0, 4, '')); my $pkt = { sth_id => $sth_id, num_cols => $num_cols, num_params => $num_params, }; PTDEBUG && _d('OK prepared packet:', Dumper($pkt)); return $pkt; } sub parse_server_handshake_packet { my ( $data ) = @_; return unless $data; PTDEBUG && _d('Server handshake data:', $data); my $handshake_pattern = qr{ ^ # ----- ---- (.+?)00 # n Null-Term String server_version (.{8}) # 4 thread_id .{16} # 8 scramble_buff .{2} # 1 filler: always 0x00 (.{4}) # 2 server_capabilities .{2} # 1 server_language .{4} # 2 server_status .{26} # 13 filler: always 0x00 }x; my ( $server_version, $thread_id, $flags ) = $data =~ m/$handshake_pattern/; my $pkt = { server_version => to_string($server_version), thread_id => to_num($thread_id), flags => parse_flags($flags), }; PTDEBUG && _d('Server handshake packet:', Dumper($pkt)); return $pkt; } sub parse_client_handshake_packet { my ( $data ) = @_; return unless $data; PTDEBUG && _d('Client handshake data:', $data); my ( $flags, $user, $buff_len ) = $data =~ m{ ^ (.{8}) # Client flags .{10} # Max packet size, charset (?:00){23} # Filler ((?:..)+?)00 # Null-terminated user name (..) # Length-coding byte for scramble buff }x; if ( !$buff_len ) { PTDEBUG && _d('Did not match client handshake packet'); return; } my $code_len = hex($buff_len); my ( $db ) = $data =~ m! ^.{64}${user}00.. # Everything matched before (?:..){$code_len} # The scramble buffer (.*?)00.*\Z # The database name !x; my $pkt = { user => to_string($user), db => $db ? to_string($db) : '', flags => parse_flags($flags), }; PTDEBUG && _d('Client handshake packet:', Dumper($pkt)); return $pkt; } sub parse_com_packet { my ( $data, $len ) = @_; return unless $data && $len; PTDEBUG && _d('COM data:', (substr($data, 0, 100).(length $data > 100 ? '...' : '')), 'len:', $len); my $code = substr($data, 0, 2); my $com = $com_for{$code}; if ( !$com ) { PTDEBUG && _d('Did not match COM packet'); return; } if ( $code ne COM_STMT_EXECUTE && $code ne COM_STMT_CLOSE && $code ne COM_STMT_RESET ) { $data = to_string(substr($data, 2, ($len - 1) * 2)); } my $pkt = { code => $code, com => $com, data => $data, }; PTDEBUG && _d('COM packet:', Dumper($pkt)); return $pkt; } sub parse_execute_packet { my ( $data, $sths ) = @_; return unless $data && $sths; my $sth_id = to_num(substr($data, 2, 8)); return unless defined $sth_id; my $sth = $sths->{$sth_id}; if ( !$sth ) { PTDEBUG && _d('Skipping unknown statement handle', $sth_id); return; } my $null_count = int(($sth->{num_params} + 7) / 8) || 1; my $null_bitmap = to_num(substr($data, 20, $null_count * 2)); PTDEBUG && _d('NULL bitmap:', $null_bitmap, 'count:', $null_count); substr($data, 0, 20 + ($null_count * 2), ''); my $new_params = to_num(substr($data, 0, 2, '')); my @types; if ( $new_params ) { PTDEBUG && _d('New param types'); for my $i ( 0..($sth->{num_params}-1) ) { my $type = to_num(substr($data, 0, 4, '')); push @types, $type_for{$type}; PTDEBUG && _d('Param', $i, 'type:', $type, $type_for{$type}); } $sth->{types} = \@types; } else { @types = @{$sth->{types}} if $data; } my $arg = $sth->{statement}; PTDEBUG && _d('Statement:', $arg); for my $i ( 0..($sth->{num_params}-1) ) { my $val; my $len; # in bytes if ( $null_bitmap & (2**$i) ) { PTDEBUG && _d('Param', $i, 'is NULL (bitmap)'); $val = 'NULL'; $len = 0; } else { if ( $unpack_type{$types[$i]} ) { ($val, $len) = $unpack_type{$types[$i]}->($data); } else { PTDEBUG && _d('No handler for param', $i, 'type', $types[$i]); $val = '?'; $len = 0; } } PTDEBUG && _d('Param', $i, 'val:', $val); $arg =~ s/\?/$val/; substr($data, 0, $len * 2, '') if $len; } my $pkt = { sth_id => $sth_id, arg => "EXECUTE $arg", }; PTDEBUG && _d('Execute packet:', Dumper($pkt)); return $pkt; } sub get_sth_id { my ( $data ) = @_; return unless $data; my $sth_id = to_num(substr($data, 2, 8)); return $sth_id; } sub parse_flags { my ( $flags ) = @_; die "I need flags" unless $flags; PTDEBUG && _d('Flag data:', $flags); my %flags = %flag_for; my $flags_dec = to_num($flags); foreach my $flag ( keys %flag_for ) { my $flagno = $flag_for{$flag}; $flags{$flag} = ($flags_dec & $flagno ? 1 : 0); } return \%flags; } sub uncompress_data { my ( $data, $len ) = @_; die "I need data" unless $data; die "I need a len argument" unless $len; die "I need a scalar reference to data" unless ref $data eq 'SCALAR'; PTDEBUG && _d('Uncompressing data'); our $InflateError; my $comp_bin_data = pack('H*', $$data); my $uncomp_bin_data = ''; my $z = new IO::Uncompress::Inflate( \$comp_bin_data ) or die "IO::Uncompress::Inflate failed: $InflateError"; my $status = $z->read(\$uncomp_bin_data, $len) or die "IO::Uncompress::Inflate failed: $InflateError"; my $uncomp_data = unpack('H*', $uncomp_bin_data); return \$uncomp_data; } sub detect_compression { my ( $self, $packet, $session ) = @_; PTDEBUG && _d('Checking for client compression'); my $com = parse_com_packet($packet->{data}, $packet->{mysql_data_len}); if ( $com && $com->{code} eq COM_SLEEP ) { PTDEBUG && _d('Client is using compression'); $session->{compress} = 1; $packet->{data} = $packet->{mysql_hdr} . $packet->{data}; return 0 unless $self->uncompress_packet($packet, $session); remove_mysql_header($packet); } else { PTDEBUG && _d('Client is NOT using compression'); $session->{compress} = 0; } return 1; } sub uncompress_packet { my ( $self, $packet, $session ) = @_; die "I need a packet" unless $packet; die "I need a session" unless $session; my $data; my $comp_hdr; my $comp_data_len; my $pkt_num; my $uncomp_data_len; eval { $data = \$packet->{data}; $comp_hdr = substr($$data, 0, 14, ''); $comp_data_len = to_num(substr($comp_hdr, 0, 6)); $pkt_num = to_num(substr($comp_hdr, 6, 2)); $uncomp_data_len = to_num(substr($comp_hdr, 8, 6)); PTDEBUG && _d('Compression header data:', $comp_hdr, 'compressed data len (bytes)', $comp_data_len, 'number', $pkt_num, 'uncompressed data len (bytes)', $uncomp_data_len); }; if ( $EVAL_ERROR ) { $session->{EVAL_ERROR} = $EVAL_ERROR; $self->fail_session($session, 'failed to parse compression header'); return 0; } if ( $uncomp_data_len ) { eval { $data = uncompress_data($data, $uncomp_data_len); $packet->{data} = $$data; }; if ( $EVAL_ERROR ) { $session->{EVAL_ERROR} = $EVAL_ERROR; $self->fail_session($session, 'failed to uncompress data'); die "Cannot uncompress packet. Check that IO::Uncompress::Inflate " . "is installed.\nError: $EVAL_ERROR"; } } else { PTDEBUG && _d('Packet is not really compressed'); $packet->{data} = $$data; } return 1; } sub remove_mysql_header { my ( $packet ) = @_; die "I need a packet" unless $packet; my $mysql_hdr = substr($packet->{data}, 0, 8, ''); my $mysql_data_len = to_num(substr($mysql_hdr, 0, 6)); my $pkt_num = to_num(substr($mysql_hdr, 6, 2)); PTDEBUG && _d('MySQL packet: header data', $mysql_hdr, 'data len (bytes)', $mysql_data_len, 'number', $pkt_num); $packet->{mysql_hdr} = $mysql_hdr; $packet->{mysql_data_len} = $mysql_data_len; $packet->{number} = $pkt_num; return; } sub _delete_buff { my ( $self, $session ) = @_; map { delete $session->{$_} } qw(buff buff_left mysql_data_len); 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 MySQLProtocolParser package # ########################################################################### # ########################################################################### # SlowLogParser 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/SlowLogParser.pm # t/lib/SlowLogParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package SlowLogParser; 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 ) = @_; my $self = { pending => [], last_event_offset => undef, }; return bless $self, $class; } my $slow_log_ts_line = qr/^# Time: ((?:[0-9: ]{15})|(?:[-0-9: T]{19}))/; my $slow_log_uh_line = qr/# User\@Host: ([^\[]+|\[[^[]+\]).*?@ (\S*) \[(.*)\]\s*(?:Id:\s*(\d+))?/; my $slow_log_hd_line = qr{ ^(?: T[cC][pP]\s[pP]ort:\s+\d+ # case differs on windows/unix | [/A-Z].*mysqld,\sVersion.*(?:started\swith:|embedded\slibrary) | Time\s+Id\s+Command ).*\n }xm; sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(next_event tell); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($next_event, $tell) = @args{@required_args}; my $pending = $self->{pending}; local $INPUT_RECORD_SEPARATOR = ";\n#"; my $trimlen = length($INPUT_RECORD_SEPARATOR); my $pos_in_log = $tell->(); my $stmt; EVENT: while ( defined($stmt = shift @$pending) or defined($stmt = $next_event->()) ) { my @properties = ('cmd', 'Query', 'pos_in_log', $pos_in_log); $self->{last_event_offset} = $pos_in_log; $pos_in_log = $tell->(); if ( $stmt =~ s/$slow_log_hd_line//go ){ # Throw away header lines in log my @chunks = split(/$INPUT_RECORD_SEPARATOR/o, $stmt); if ( @chunks > 1 ) { PTDEBUG && _d("Found multiple chunks"); $stmt = shift @chunks; unshift @$pending, @chunks; } } $stmt = '#' . $stmt unless $stmt =~ m/\A#/; $stmt =~ s/;\n#?\Z//; my ($got_ts, $got_uh, $got_ac, $got_db, $got_set, $got_embed); my $pos = 0; my $len = length($stmt); my $found_arg = 0; LINE: while ( $stmt =~ m/^(.*)$/mg ) { # /g is important, requires scalar match. $pos = pos($stmt); # Be careful not to mess this up! my $line = $1; # Necessary for /g and pos() to work. PTDEBUG && _d($line); if ($line =~ m/^(?:#|use |SET (?:last_insert_id|insert_id|timestamp))/o) { if ( !$got_ts && (my ( $time ) = $line =~ m/$slow_log_ts_line/o)) { PTDEBUG && _d("Got ts", $time); push @properties, 'ts', $time; ++$got_ts; if ( !$got_uh && ( my ( $user, $host, $ip, $thread_id ) = $line =~ m/$slow_log_uh_line/o ) ) { PTDEBUG && _d("Got user, host, ip", $user, $host, $ip); $host ||= $ip; # sometimes host is missing when using skip-name-resolve (LP #issue 1262456) push @properties, 'user', $user, 'host', $host, 'ip', $ip; if ( $thread_id ) { push @properties, 'Thread_id', $thread_id; } ++$got_uh; } } elsif ( !$got_uh && ( my ( $user, $host, $ip, $thread_id ) = $line =~ m/$slow_log_uh_line/o ) ) { PTDEBUG && _d("Got user, host, ip", $user, $host, $ip); $host ||= $ip; # sometimes host is missing when using skip-name-resolve (LP #issue 1262456) push @properties, 'user', $user, 'host', $host, 'ip', $ip; if ( $thread_id ) { push @properties, 'Thread_id', $thread_id; } ++$got_uh; } elsif (!$got_ac && $line =~ m/^# (?:administrator command:.*)$/) { PTDEBUG && _d("Got admin command"); $line =~ s/^#\s+//; # string leading "# ". push @properties, 'cmd', 'Admin', 'arg', $line; push @properties, 'bytes', length($properties[-1]); ++$found_arg; ++$got_ac; } elsif ( $line =~ m/^# +[A-Z][A-Za-z_]+: \S+/ ) { # Make the test cheap! PTDEBUG && _d("Got some line with properties"); if ( $line =~ m/Schema:\s+\w+: / ) { PTDEBUG && _d('Removing empty Schema attrib'); $line =~ s/Schema:\s+//; PTDEBUG && _d($line); } my @temp = $line =~ m/(\w+):\s+(\S+|\Z)/g; push @properties, @temp; } elsif ( !$got_db && (my ( $db ) = $line =~ m/^use ([^;]+)/ ) ) { PTDEBUG && _d("Got a default database:", $db); push @properties, 'db', $db; ++$got_db; } elsif (!$got_set && (my ($setting) = $line =~ m/^SET\s+([^;]*)/)) { PTDEBUG && _d("Got some setting:", $setting); push @properties, split(/,|\s*=\s*/, $setting); ++$got_set; } if ( !$found_arg && $pos == $len ) { PTDEBUG && _d("Did not find arg, looking for special cases"); local $INPUT_RECORD_SEPARATOR = ";\n"; # get next line if ( defined(my $l = $next_event->()) ) { if ( $l =~ /^\s*[A-Z][a-z_]+: / ) { PTDEBUG && _d("Found NULL query before", $l); local $INPUT_RECORD_SEPARATOR = ";\n#"; my $rest_of_event = $next_event->(); push @{$self->{pending}}, $l . $rest_of_event; push @properties, 'cmd', 'Query', 'arg', '/* No query */'; push @properties, 'bytes', 0; $found_arg++; } else { chomp $l; $l =~ s/^\s+//; PTDEBUG && _d("Found admin statement", $l); push @properties, 'cmd', 'Admin', 'arg', $l; push @properties, 'bytes', length($properties[-1]); $found_arg++; } } else { PTDEBUG && _d("I can't figure out what to do with this line"); next EVENT; } } } else { PTDEBUG && _d("Got the query/arg line"); my $arg = substr($stmt, $pos - length($line)); push @properties, 'arg', $arg, 'bytes', length($arg); if ( $args{misc} && $args{misc}->{embed} && ( my ($e) = $arg =~ m/($args{misc}->{embed})/) ) { push @properties, $e =~ m/$args{misc}->{capture}/g; } last LINE; } } PTDEBUG && _d('Properties of event:', Dumper(\@properties)); my $event = { @properties }; if ( !$event->{arg} ) { PTDEBUG && _d('Partial event, no arg'); } else { $self->{last_event_offset} = undef; if ( $args{stats} ) { $args{stats}->{events_read}++; $args{stats}->{events_parsed}++; } } return $event; } # EVENT @$pending = (); $args{oktorun}->(0) if $args{oktorun}; 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 SlowLogParser package # ########################################################################### # ########################################################################### # SlowLogWriter 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/SlowLogWriter.pm # t/lib/SlowLogWriter.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package SlowLogWriter; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; sub new { my ( $class ) = @_; bless {}, $class; } sub write { my ( $self, $fh, $event ) = @_; if ( $event->{ts} ) { print $fh "# Time: $event->{ts}\n"; } if ( $event->{user} ) { printf $fh "# User\@Host: %s[%s] \@ %s []\n", $event->{user}, $event->{user}, $event->{host}; } if ( $event->{ip} && $event->{port} ) { printf $fh "# Client: $event->{ip}:$event->{port}\n"; } if ( $event->{Thread_id} ) { printf $fh "# Thread_id: $event->{Thread_id}\n"; } my $percona_patched = exists $event->{QC_Hit} ? 1 : 0; printf $fh "# Query_time: %.6f Lock_time: %.6f Rows_sent: %d Rows_examined: %d\n", map { $_ || 0 } @{$event}{qw(Query_time Lock_time Rows_sent Rows_examined)}; if ( $percona_patched ) { printf $fh "# QC_Hit: %s Full_scan: %s Full_join: %s Tmp_table: %s Tmp_table_on_disk: %s\n# Filesort: %s Filesort_on_disk: %s Merge_passes: %d\n", map { $_ || 0 } @{$event}{qw(QC_Hit Full_scan Full_join Tmp_table Tmp_table_on_disk Filesort Filesort_on_disk Merge_passes)}; if ( exists $event->{InnoDB_IO_r_ops} ) { printf $fh "# InnoDB_IO_r_ops: %d InnoDB_IO_r_bytes: %d InnoDB_IO_r_wait: %s\n# InnoDB_rec_lock_wait: %s InnoDB_queue_wait: %s\n# InnoDB_pages_distinct: %d\n", map { $_ || 0 } @{$event}{qw(InnoDB_IO_r_ops InnoDB_IO_r_bytes InnoDB_IO_r_wait InnoDB_rec_lock_wait InnoDB_queue_wait InnoDB_pages_distinct)}; } else { printf $fh "# No InnoDB statistics available for this query\n"; } } if ( $event->{db} ) { printf $fh "use %s;\n", $event->{db}; } if ( $event->{arg} =~ m/^administrator command/ ) { print $fh '# '; } print $fh $event->{arg}, ";\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 SlowLogWriter package # ########################################################################### # ########################################################################### # EventAggregator 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/EventAggregator.pm # t/lib/EventAggregator.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package EventAggregator; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; use List::Util qw(min max); use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; use Digest::MD5 qw(md5); use constant BUCK_SIZE => 1.05; use constant BASE_LOG => log(BUCK_SIZE); use constant BASE_OFFSET => abs(1 - log(0.000001) / BASE_LOG); # 284.1617969 use constant NUM_BUCK => 1000; use constant MIN_BUCK => .000001; my @buck_vals = map { bucket_value($_); } (0..NUM_BUCK-1); sub new { my ( $class, %args ) = @_; foreach my $arg ( qw(groupby worst) ) { die "I need a $arg argument" unless $args{$arg}; } my $attributes = $args{attributes} || {}; my $self = { groupby => $args{groupby}, detect_attribs => scalar keys %$attributes == 0 ? 1 : 0, all_attribs => [ keys %$attributes ], ignore_attribs => { map { $_ => $args{attributes}->{$_} } grep { $_ ne $args{groupby} } @{$args{ignore_attributes}} }, attributes => { map { $_ => $args{attributes}->{$_} } grep { $_ ne $args{groupby} } keys %$attributes }, alt_attribs => { map { $_ => make_alt_attrib(@{$args{attributes}->{$_}}) } grep { $_ ne $args{groupby} } keys %$attributes }, worst => $args{worst}, unroll_limit => $ENV{PT_QUERY_DIGEST_CHECK_ATTRIB_LIMIT} || 1000, attrib_limit => $args{attrib_limit}, result_classes => {}, result_globals => {}, result_samples => {}, class_metrics => {}, global_metrics => {}, n_events => 0, unrolled_loops => undef, type_for => { %{$args{type_for} || { Query_time => 'num' }} }, }; return bless $self, $class; } sub reset_aggregated_data { my ( $self ) = @_; foreach my $class ( values %{$self->{result_classes}} ) { foreach my $attrib ( values %$class ) { delete @{$attrib}{keys %$attrib}; } } foreach my $class ( values %{$self->{result_globals}} ) { delete @{$class}{keys %$class}; } delete @{$self->{result_samples}}{keys %{$self->{result_samples}}}; $self->{n_events} = 0; } sub aggregate { my ( $self, $event ) = @_; my $group_by = $event->{$self->{groupby}}; return unless defined $group_by; $self->{n_events}++; PTDEBUG && _d('Event', $self->{n_events}); return $self->{unrolled_loops}->($self, $event, $group_by) if $self->{unrolled_loops}; if ( $self->{n_events} <= $self->{unroll_limit} ) { $self->add_new_attributes($event) if $self->{detect_attribs}; ATTRIB: foreach my $attrib ( keys %{$self->{attributes}} ) { if ( !exists $event->{$attrib} ) { PTDEBUG && _d("attrib doesn't exist in event:", $attrib); my $alt_attrib = $self->{alt_attribs}->{$attrib}->($event); PTDEBUG && _d('alt attrib:', $alt_attrib); next ATTRIB unless $alt_attrib; } GROUPBY: foreach my $val ( ref $group_by ? @$group_by : ($group_by) ) { my $class_attrib = $self->{result_classes}->{$val}->{$attrib} ||= {}; my $global_attrib = $self->{result_globals}->{$attrib} ||= {}; my $samples = $self->{result_samples}; my $handler = $self->{handlers}->{ $attrib }; if ( !$handler ) { $handler = $self->make_handler( event => $event, attribute => $attrib, alternates => $self->{attributes}->{$attrib}, worst => $self->{worst} eq $attrib, ); $self->{handlers}->{$attrib} = $handler; } next GROUPBY unless $handler; $samples->{$val} ||= $event; # Initialize to the first event. $handler->($event, $class_attrib, $global_attrib, $samples, $group_by); } } } else { $self->_make_unrolled_loops($event); $self->{unrolled_loops}->($self, $event, $group_by); } return; } sub _make_unrolled_loops { my ( $self, $event ) = @_; my $group_by = $event->{$self->{groupby}}; my @attrs = grep { $self->{handlers}->{$_} } keys %{$self->{attributes}}; my $globs = $self->{result_globals}; # Global stats for each my $samples = $self->{result_samples}; my @lines = ( 'my ( $self, $event, $group_by ) = @_;', 'my ($val, $class, $global, $idx);', (ref $group_by ? ('foreach my $group_by ( @$group_by ) {') : ()), 'my $temp = $self->{result_classes}->{ $group_by } ||= { map { $_ => { } } @attrs };', '$samples->{$group_by} ||= $event;', # Always start with the first. ); foreach my $i ( 0 .. $#attrs ) { push @lines, ( '$class = $temp->{\'' . $attrs[$i] . '\'};', '$global = $globs->{\'' . $attrs[$i] . '\'};', $self->{unrolled_for}->{$attrs[$i]}, ); } if ( ref $group_by ) { push @lines, '}'; # Close the loop opened above } @lines = map { s/^/ /gm; $_ } @lines; # Indent for debugging unshift @lines, 'sub {'; push @lines, '}'; my $code = join("\n", @lines); PTDEBUG && _d('Unrolled subroutine:', @lines); my $sub = eval $code; die $EVAL_ERROR if $EVAL_ERROR; $self->{unrolled_loops} = $sub; return; } sub results { my ( $self ) = @_; return { classes => $self->{result_classes}, globals => $self->{result_globals}, samples => $self->{result_samples}, }; } sub set_results { my ( $self, $results ) = @_; $self->{result_classes} = $results->{classes}; $self->{result_globals} = $results->{globals}; $self->{result_samples} = $results->{samples}; return; } sub stats { my ( $self ) = @_; return { classes => $self->{class_metrics}, globals => $self->{global_metrics}, }; } sub attributes { my ( $self ) = @_; return $self->{type_for}; } sub set_attribute_types { my ( $self, $attrib_types ) = @_; $self->{type_for} = $attrib_types; return; } sub type_for { my ( $self, $attrib ) = @_; return $self->{type_for}->{$attrib}; } sub make_handler { my ( $self, %args ) = @_; my @required_args = qw(event attribute); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($event, $attrib) = @args{@required_args}; my $val; eval { $val= $self->_get_value(%args); }; if ( $EVAL_ERROR ) { PTDEBUG && _d("Cannot make", $attrib, "handler:", $EVAL_ERROR); return; } return unless defined $val; # can't determine type if it's undef my $float_re = qr{[+-]?(?:(?=\d|[.])\d+(?:[.])\d{0,})(?:E[+-]?\d+)?}i; my $type = $self->type_for($attrib) ? $self->type_for($attrib) : $attrib =~ m/_crc$/ ? 'string' : $val =~ m/^(?:\d+|$float_re)$/o ? 'num' : $val =~ m/^(?:Yes|No)$/ ? 'bool' : 'string'; PTDEBUG && _d('Type for', $attrib, 'is', $type, '(sample:', $val, ')'); $self->{type_for}->{$attrib} = $type; my @lines; my %track = ( sum => $type =~ m/num|bool/ ? 1 : 0, # sum of values unq => $type =~ m/bool|string/ ? 1 : 0, # count of unique values seen all => $type eq 'num' ? 1 : 0, # all values in bucketed list ); my $trf = ($type eq 'bool') ? q{(($val || '') eq 'Yes') ? 1 : 0} : undef; if ( $trf ) { push @lines, q{$val = } . $trf . ';'; } if ( $attrib eq 'Query_time' ) { push @lines, ( '$val =~ s/^(\d+(?:\.\d+)?).*/$1/;', '$event->{\''.$attrib.'\'} = $val;', ); } if ( $type eq 'num' && $self->{attrib_limit} ) { push @lines, ( "if ( \$val > $self->{attrib_limit} ) {", ' $val = $class->{last} ||= 0;', '}', '$class->{last} = $val;', ); } my $lt = $type eq 'num' ? '<' : 'lt'; my $gt = $type eq 'num' ? '>' : 'gt'; foreach my $place ( qw($class $global) ) { my @tmp; # hold lines until PLACE placeholder is replaced push @tmp, '++PLACE->{cnt};'; # count of all values seen if ( $attrib =~ m/_crc$/ ) { push @tmp, '$val = $val % 1_000;'; } push @tmp, ( 'PLACE->{min} = $val if !defined PLACE->{min} || $val ' . $lt . ' PLACE->{min};', ); push @tmp, ( 'PLACE->{max} = $val if !defined PLACE->{max} || $val ' . $gt . ' PLACE->{max};', ); if ( $track{sum} ) { push @tmp, 'PLACE->{sum} += $val;'; } if ( $track{all} ) { push @tmp, ( 'exists PLACE->{all} or PLACE->{all} = {};', '++PLACE->{all}->{ EventAggregator::bucket_idx($val) };', ); } push @lines, map { s/PLACE/$place/g; $_ } @tmp; } if ( $track{unq} ) { push @lines, '++$class->{unq}->{$val}'; } if ( $args{worst} ) { my $op = $type eq 'num' ? '>=' : 'ge'; push @lines, ( 'if ( $val ' . $op . ' ($class->{max} || 0) ) {', ' $samples->{$group_by} = $event;', '}', ); } my @unrolled = ( "\$val = \$event->{'$attrib'};", ( map { "\$val = \$event->{'$_'} unless defined \$val;" } grep { $_ ne $attrib } @{$args{alternates}} ), 'defined $val && do {', @lines, '};', ); $self->{unrolled_for}->{$attrib} = join("\n", @unrolled); my @code = ( 'sub {', 'my ( $event, $class, $global, $samples, $group_by ) = @_;', 'my ($val, $idx);', $self->{unrolled_for}->{$attrib}, 'return;', '}', ); $self->{code_for}->{$attrib} = join("\n", @code); PTDEBUG && _d($attrib, 'handler code:', $self->{code_for}->{$attrib}); my $sub = eval $self->{code_for}->{$attrib}; if ( $EVAL_ERROR ) { die "Failed to compile $attrib handler code: $EVAL_ERROR"; } return $sub; } sub bucket_idx { my ( $val ) = @_; return 0 if $val < MIN_BUCK; my $idx = int(BASE_OFFSET + log($val)/BASE_LOG); return $idx > (NUM_BUCK-1) ? (NUM_BUCK-1) : $idx; } sub bucket_value { my ( $bucket ) = @_; return 0 if $bucket == 0; die "Invalid bucket: $bucket" if $bucket < 0 || $bucket > (NUM_BUCK-1); return (BUCK_SIZE**($bucket-1)) * MIN_BUCK; } { my @buck_tens; sub buckets_of { return @buck_tens if @buck_tens; my $start_bucket = 0; my @base10_starts = (0); map { push @base10_starts, (10**$_)*MIN_BUCK } (1..7); for my $base10_bucket ( 0..($#base10_starts-1) ) { my $next_bucket = bucket_idx( $base10_starts[$base10_bucket+1] ); PTDEBUG && _d('Base 10 bucket', $base10_bucket, 'maps to', 'base 1.05 buckets', $start_bucket, '..', $next_bucket-1); for my $base1_05_bucket ($start_bucket..($next_bucket-1)) { $buck_tens[$base1_05_bucket] = $base10_bucket; } $start_bucket = $next_bucket; } map { $buck_tens[$_] = 7 } ($start_bucket..(NUM_BUCK-1)); return @buck_tens; } } sub calculate_statistical_metrics { my ( $self, %args ) = @_; my $classes = $self->{result_classes}; my $globals = $self->{result_globals}; my $class_metrics = $self->{class_metrics}; my $global_metrics = $self->{global_metrics}; PTDEBUG && _d('Calculating statistical_metrics'); foreach my $attrib ( keys %$globals ) { if ( exists $globals->{$attrib}->{all} ) { $global_metrics->{$attrib} = $self->_calc_metrics( $globals->{$attrib}->{all}, $globals->{$attrib}, ); } foreach my $class ( keys %$classes ) { if ( exists $classes->{$class}->{$attrib}->{all} ) { $class_metrics->{$class}->{$attrib} = $self->_calc_metrics( $classes->{$class}->{$attrib}->{all}, $classes->{$class}->{$attrib} ); } } } return; } sub _calc_metrics { my ( $self, $vals, $args ) = @_; my $statistical_metrics = { pct_95 => 0, stddev => 0, median => 0, cutoff => undef, }; return $statistical_metrics unless defined $vals && %$vals && $args->{cnt}; my $n_vals = $args->{cnt}; if ( $n_vals == 1 || $args->{max} == $args->{min} ) { my $v = $args->{max} || 0; my $bucket = int(6 + ( log($v > 0 ? $v : MIN_BUCK) / log(10))); $bucket = $bucket > 7 ? 7 : $bucket < 0 ? 0 : $bucket; return { pct_95 => $v, stddev => 0, median => $v, cutoff => $n_vals, }; } elsif ( $n_vals == 2 ) { foreach my $v ( $args->{min}, $args->{max} ) { my $bucket = int(6 + ( log($v && $v > 0 ? $v : MIN_BUCK) / log(10))); $bucket = $bucket > 7 ? 7 : $bucket < 0 ? 0 : $bucket; } my $v = $args->{max} || 0; my $mean = (($args->{min} || 0) + $v) / 2; return { pct_95 => $v, stddev => sqrt((($v - $mean) ** 2) *2), median => $mean, cutoff => $n_vals, }; } my $cutoff = $n_vals >= 10 ? int ( $n_vals * 0.95 ) : $n_vals; $statistical_metrics->{cutoff} = $cutoff; my $total_left = $n_vals; my $top_vals = $n_vals - $cutoff; # vals > 95th my $sum_excl = 0; my $sum = 0; my $sumsq = 0; my $mid = int($n_vals / 2); my $median = 0; my $prev = NUM_BUCK-1; # Used for getting median when $cutoff is odd my $bucket_95 = 0; # top bucket in 95th PTDEBUG && _d('total vals:', $total_left, 'top vals:', $top_vals, 'mid:', $mid); my @buckets = map { 0 } (0..NUM_BUCK-1); map { $buckets[$_] = $vals->{$_} } keys %$vals; $vals = \@buckets; # repoint vals from given hashref to our array BUCKET: for my $bucket ( reverse 0..(NUM_BUCK-1) ) { my $val = $vals->[$bucket]; next BUCKET unless $val; $total_left -= $val; $sum_excl += $val; $bucket_95 = $bucket if !$bucket_95 && $sum_excl > $top_vals; if ( !$median && $total_left <= $mid ) { $median = (($cutoff % 2) || ($val > 1)) ? $buck_vals[$bucket] : ($buck_vals[$bucket] + $buck_vals[$prev]) / 2; } $sum += $val * $buck_vals[$bucket]; $sumsq += $val * ($buck_vals[$bucket]**2); $prev = $bucket; } my $var = $sumsq/$n_vals - ( ($sum/$n_vals) ** 2 ); my $stddev = $var > 0 ? sqrt($var) : 0; my $maxstdev = (($args->{max} || 0) - ($args->{min} || 0)) / 2; $stddev = $stddev > $maxstdev ? $maxstdev : $stddev; PTDEBUG && _d('sum:', $sum, 'sumsq:', $sumsq, 'stddev:', $stddev, 'median:', $median, 'prev bucket:', $prev, 'total left:', $total_left, 'sum excl', $sum_excl, 'bucket 95:', $bucket_95, $buck_vals[$bucket_95]); $statistical_metrics->{stddev} = $stddev; $statistical_metrics->{pct_95} = $buck_vals[$bucket_95]; $statistical_metrics->{median} = $median; return $statistical_metrics; } sub metrics { my ( $self, %args ) = @_; foreach my $arg ( qw(attrib where) ) { die "I need a $arg argument" unless defined $args{$arg}; } my $attrib = $args{attrib}; my $where = $args{where}; my $stats = $self->results(); my $metrics = $self->stats(); my $store = $stats->{classes}->{$where}->{$attrib}; my $global_cnt = $stats->{globals}->{$attrib}->{cnt}; return { cnt => $store->{cnt}, pct => $global_cnt && $store->{cnt} ? $store->{cnt} / $global_cnt : 0, sum => $store->{sum}, min => $store->{min}, max => $store->{max}, avg => $store->{sum} && $store->{cnt} ? $store->{sum} / $store->{cnt} : 0, median => $metrics->{classes}->{$where}->{$attrib}->{median} || 0, pct_95 => $metrics->{classes}->{$where}->{$attrib}->{pct_95} || 0, stddev => $metrics->{classes}->{$where}->{$attrib}->{stddev} || 0, }; } sub top_events { my ( $self, %args ) = @_; my $classes = $self->{result_classes}; my @sorted = reverse sort { # Sorted list of $groupby values $classes->{$a}->{$args{attrib}}->{$args{orderby}} <=> $classes->{$b}->{$args{attrib}}->{$args{orderby}} || tiebreaker($classes->{$a}, $classes->{$b}); } grep { defined $classes->{$_}->{$args{attrib}}->{$args{orderby}} } keys %$classes; # this should first be sorted for test consistency, but many tests already in place would fail my @chosen; # top events my @other; # other events (< top) my ($total, $count) = (0, 0); foreach my $groupby ( @sorted ) { if ( (!$args{total} || $total < $args{total} ) && ( !$args{count} || $count < $args{count} ) ) { push @chosen, [$groupby, 'top', $count+1]; } elsif ( $args{ol_attrib} && (!$args{ol_freq} || $classes->{$groupby}->{$args{ol_attrib}}->{cnt} >= $args{ol_freq}) ) { my $stats = $self->{class_metrics}->{$groupby}->{$args{ol_attrib}}; if ( ($stats->{pct_95} || 0) >= $args{ol_limit} ) { push @chosen, [$groupby, 'outlier', $count+1]; } else { push @other, [$groupby, 'misc', $count+1]; } } else { push @other, [$groupby, 'misc', $count+1]; } $total += $classes->{$groupby}->{$args{attrib}}->{$args{orderby}}; $count++; } return \@chosen, \@other; } sub tiebreaker { my ($a, $b) = @_; if (defined $a->{pos_in_log}) { return $a->{pos_in_log}->{max} cmp $b->{pos_in_log}->{max}; } return 0; } sub add_new_attributes { my ( $self, $event ) = @_; return unless $event; map { my $attrib = $_; $self->{attributes}->{$attrib} = [$attrib]; $self->{alt_attribs}->{$attrib} = make_alt_attrib($attrib); push @{$self->{all_attribs}}, $attrib; PTDEBUG && _d('Added new attribute:', $attrib); } grep { $_ ne $self->{groupby} && !exists $self->{attributes}->{$_} && !exists $self->{ignore_attribs}->{$_} } keys %$event; return; } sub get_attributes { my ( $self ) = @_; return $self->{all_attribs}; } sub events_processed { my ( $self ) = @_; return $self->{n_events}; } sub make_alt_attrib { my ( @attribs ) = @_; my $attrib = shift @attribs; # Primary attribute. return sub {} unless @attribs; # No alternates. my @lines; push @lines, 'sub { my ( $event ) = @_; my $alt_attrib;'; push @lines, map { "\$alt_attrib = '$_' if !defined \$alt_attrib " . "&& exists \$event->{'$_'};" } @attribs; push @lines, 'return $alt_attrib; }'; PTDEBUG && _d('alt attrib sub for', $attrib, ':', @lines); my $sub = eval join("\n", @lines); die if $EVAL_ERROR; return $sub; } sub merge { my ( @ea_objs ) = @_; PTDEBUG && _d('Merging', scalar @ea_objs, 'ea'); return unless scalar @ea_objs; my $ea1 = shift @ea_objs; my $r1 = $ea1->results; my $worst = $ea1->{worst}; # for merging, finding worst sample my %attrib_types = %{ $ea1->attributes() }; foreach my $ea ( @ea_objs ) { die "EventAggregator objects have different groupby: " . "$ea1->{groupby} and $ea->{groupby}" unless $ea1->{groupby} eq $ea->{groupby}; die "EventAggregator objects have different worst: " . "$ea1->{worst} and $ea->{worst}" unless $ea1->{worst} eq $ea->{worst}; my $attrib_types = $ea->attributes(); map { $attrib_types{$_} = $attrib_types->{$_} unless exists $attrib_types{$_}; } keys %$attrib_types; } my $r_merged = { classes => {}, globals => _deep_copy_attribs($r1->{globals}), samples => {}, }; map { $r_merged->{classes}->{$_} = _deep_copy_attribs($r1->{classes}->{$_}); @{$r_merged->{samples}->{$_}}{keys %{$r1->{samples}->{$_}}} = values %{$r1->{samples}->{$_}}; } keys %{$r1->{classes}}; for my $i ( 0..$#ea_objs ) { PTDEBUG && _d('Merging ea obj', ($i + 1)); my $r2 = $ea_objs[$i]->results; eval { CLASS: foreach my $class ( keys %{$r2->{classes}} ) { my $r1_class = $r_merged->{classes}->{$class}; my $r2_class = $r2->{classes}->{$class}; if ( $r1_class && $r2_class ) { CLASS_ATTRIB: foreach my $attrib ( keys %$r2_class ) { PTDEBUG && _d('merge', $attrib); if ( $r1_class->{$attrib} && $r2_class->{$attrib} ) { _add_attrib_vals($r1_class->{$attrib}, $r2_class->{$attrib}); } elsif ( !$r1_class->{$attrib} ) { PTDEBUG && _d('copy', $attrib); $r1_class->{$attrib} = _deep_copy_attrib_vals($r2_class->{$attrib}) } } } elsif ( !$r1_class ) { PTDEBUG && _d('copy class'); $r_merged->{classes}->{$class} = _deep_copy_attribs($r2_class); } my $new_worst_sample; if ( $r_merged->{samples}->{$class} && $r2->{samples}->{$class} ) { if ( $r2->{samples}->{$class}->{$worst} > $r_merged->{samples}->{$class}->{$worst} ) { $new_worst_sample = $r2->{samples}->{$class} } } elsif ( !$r_merged->{samples}->{$class} ) { $new_worst_sample = $r2->{samples}->{$class}; } if ( $new_worst_sample ) { PTDEBUG && _d('New worst sample:', $worst, '=', $new_worst_sample->{$worst}, 'item:', substr($class, 0, 100)); my %new_sample; @new_sample{keys %$new_worst_sample} = values %$new_worst_sample; $r_merged->{samples}->{$class} = \%new_sample; } } }; if ( $EVAL_ERROR ) { warn "Error merging class/sample: $EVAL_ERROR"; } eval { GLOBAL_ATTRIB: PTDEBUG && _d('Merging global attributes'); foreach my $attrib ( keys %{$r2->{globals}} ) { my $r1_global = $r_merged->{globals}->{$attrib}; my $r2_global = $r2->{globals}->{$attrib}; if ( $r1_global && $r2_global ) { PTDEBUG && _d('merge', $attrib); _add_attrib_vals($r1_global, $r2_global); } elsif ( !$r1_global ) { PTDEBUG && _d('copy', $attrib); $r_merged->{globals}->{$attrib} = _deep_copy_attrib_vals($r2_global); } } }; if ( $EVAL_ERROR ) { warn "Error merging globals: $EVAL_ERROR"; } } my $ea_merged = new EventAggregator( groupby => $ea1->{groupby}, worst => $ea1->{worst}, attributes => { map { $_=>[$_] } keys %attrib_types }, ); $ea_merged->set_results($r_merged); $ea_merged->set_attribute_types(\%attrib_types); return $ea_merged; } sub _add_attrib_vals { my ( $vals1, $vals2 ) = @_; foreach my $val ( keys %$vals1 ) { my $val1 = $vals1->{$val}; my $val2 = $vals2->{$val}; if ( (!ref $val1) && (!ref $val2) ) { die "undefined $val value" unless defined $val1 && defined $val2; my $is_num = exists $vals1->{sum} ? 1 : 0; if ( $val eq 'max' ) { if ( $is_num ) { $vals1->{$val} = $val1 > $val2 ? $val1 : $val2; } else { $vals1->{$val} = $val1 gt $val2 ? $val1 : $val2; } } elsif ( $val eq 'min' ) { if ( $is_num ) { $vals1->{$val} = $val1 < $val2 ? $val1 : $val2; } else { $vals1->{$val} = $val1 lt $val2 ? $val1 : $val2; } } else { $vals1->{$val} += $val2; } } elsif ( (ref $val1 eq 'ARRAY') && (ref $val2 eq 'ARRAY') ) { die "Empty $val arrayref" unless @$val1 && @$val2; my $n_buckets = (scalar @$val1) - 1; for my $i ( 0..$n_buckets ) { $vals1->{$val}->[$i] += $val2->[$i]; } } elsif ( (ref $val1 eq 'HASH') && (ref $val2 eq 'HASH') ) { die "Empty $val hashref" unless %$val1 and %$val2; map { $vals1->{$val}->{$_} += $val2->{$_} } keys %$val2; } else { PTDEBUG && _d('vals1:', Dumper($vals1)); PTDEBUG && _d('vals2:', Dumper($vals2)); die "$val type mismatch"; } } return; } sub _deep_copy_attribs { my ( $attribs ) = @_; my $copy = {}; foreach my $attrib ( keys %$attribs ) { $copy->{$attrib} = _deep_copy_attrib_vals($attribs->{$attrib}); } return $copy; } sub _deep_copy_attrib_vals { my ( $vals ) = @_; my $copy; if ( ref $vals eq 'HASH' ) { $copy = {}; foreach my $val ( keys %$vals ) { if ( my $ref_type = ref $val ) { if ( $ref_type eq 'ARRAY' ) { my $n_elems = (scalar @$val) - 1; $copy->{$val} = [ map { undef } ( 0..$n_elems ) ]; for my $i ( 0..$n_elems ) { $copy->{$val}->[$i] = $vals->{$val}->[$i]; } } elsif ( $ref_type eq 'HASH' ) { $copy->{$val} = {}; map { $copy->{$val}->{$_} += $vals->{$val}->{$_} } keys %{$vals->{$val}} } else { die "I don't know how to deep copy a $ref_type reference"; } } else { $copy->{$val} = $vals->{$val}; } } } else { $copy = $vals; } return $copy; } sub _get_value { my ( $self, %args ) = @_; my ($event, $attrib, $alts) = @args{qw(event attribute alternates)}; return unless $event && $attrib; my $value; if ( exists $event->{$attrib} ) { $value = $event->{$attrib}; } elsif ( $alts ) { my $found_value = 0; foreach my $alt_attrib( @$alts ) { if ( exists $event->{$alt_attrib} ) { $value = $event->{$alt_attrib}; $found_value = 1; last; } } die "Event does not have attribute $attrib or any of its alternates" unless $found_value; } else { die "Event does not have attribute $attrib and there are no alterantes"; } return $value; } 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 EventAggregator 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 # ########################################################################### # ########################################################################### # QueryReportFormatter 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/QueryReportFormatter.pm # t/lib/QueryReportFormatter.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryReportFormatter; use Lmo; use English qw(-no_match_vars); use POSIX qw(floor); Transformers->import(qw( shorten micro_t parse_timestamp unix_timestamp make_checksum percentage_of crc32 )); use constant PTDEBUG => $ENV{PTDEBUG} || 0; use constant LINE_LENGTH => 74; use constant MAX_STRING_LENGTH => 10; { local $EVAL_ERROR; eval { require Quoter } }; { local $EVAL_ERROR; eval { require ReportFormatter } }; has Quoter => ( is => 'ro', isa => 'Quoter', default => sub { Quoter->new() }, ); has label_width => ( is => 'ro', isa => 'Int', ); has global_headers => ( is => 'ro', isa => 'ArrayRef', default => sub { [qw( total min max avg 95% stddev median)] }, ); has event_headers => ( is => 'ro', isa => 'ArrayRef', default => sub { [qw(pct total min max avg 95% stddev median)] }, ); has show_all => ( is => 'ro', isa => 'HashRef', default => sub { {} }, ); has ReportFormatter => ( is => 'ro', isa => 'ReportFormatter', builder => '_build_report_formatter', ); sub _build_report_formatter { return ReportFormatter->new( line_width => LINE_LENGTH, extend_right => 1, ); } sub BUILDARGS { my $class = shift; my $args = $class->SUPER::BUILDARGS(@_); foreach my $arg ( qw(OptionParser QueryRewriter) ) { die "I need a $arg argument" unless $args->{$arg}; } my $label_width = $args->{label_width} ||= 12; PTDEBUG && _d('Label width:', $label_width); my $o = delete $args->{OptionParser}; my $self = { %$args, options => { shorten => 1024, report_all => $o->get('report-all'), report_histogram => $o->get('report-histogram'), }, num_format => '# %1$-'.$label_width.'s %2$3s %3$7s %4$7s %5$7s %6$7s %7$7s %8$7s %9$7s', bool_format => '# %1$-'.$label_width.'s %2$3d%% yes, %3$3d%% no', string_format => '# %1$-'.$label_width.'s %2$s', hidden_attrib => { # Don't sort/print these attribs in the reports. arg => 1, # They're usually handled specially, or not fingerprint => 1, # printed at all. pos_in_log => 1, ts => 1, }, }; return $self; } sub print_reports { my ( $self, %args ) = @_; foreach my $arg ( qw(reports ea worst orderby groupby) ) { die "I need a $arg argument" unless exists $args{$arg}; } my $reports = $args{reports}; my $group = $args{group}; my $last_report; foreach my $report ( @$reports ) { PTDEBUG && _d('Printing', $report, 'report'); my $report_output = $self->$report(%args); if ( $report_output ) { print "\n" if !$last_report || !($group->{$last_report} && $group->{$report}); print $report_output; } else { PTDEBUG && _d('No', $report, 'report'); } $last_report = $report; } return; } sub rusage { my ( $self ) = @_; my ( $rss, $vsz, $user, $system ) = ( 0, 0, 0, 0 ); my $rusage = ''; eval { my $mem = `ps -o rss,vsz -p $PID 2>&1`; ( $rss, $vsz ) = $mem =~ m/(\d+)/g; ( $user, $system ) = times(); $rusage = sprintf "# %s user time, %s system time, %s rss, %s vsz\n", micro_t( $user, p_s => 1, p_ms => 1 ), micro_t( $system, p_s => 1, p_ms => 1 ), shorten( ($rss || 0) * 1_024 ), shorten( ($vsz || 0) * 1_024 ); }; if ( $EVAL_ERROR ) { PTDEBUG && _d($EVAL_ERROR); } return $rusage ? $rusage : "# Could not get rusage\n"; } sub date { my ( $self ) = @_; return "# Current date: " . (scalar localtime) . "\n"; } sub hostname { my ( $self ) = @_; my $hostname = `hostname`; if ( $hostname ) { chomp $hostname; return "# Hostname: $hostname\n"; } return; } sub files { my ( $self, %args ) = @_; if ( $args{files} ) { return "# Files: " . join(', ', map { $_->{name} } @{$args{files}}) . "\n"; } return; } sub header { my ( $self, %args ) = @_; foreach my $arg ( qw(ea orderby) ) { die "I need a $arg argument" unless defined $args{$arg}; } my $ea = $args{ea}; my $orderby = $args{orderby}; my $results = $ea->results(); my @result; my $global_cnt = $results->{globals}->{$orderby}->{cnt} || 0; my ($qps, $conc) = (0, 0); if ( $global_cnt && $results->{globals}->{ts} && ($results->{globals}->{ts}->{max} || '') gt ($results->{globals}->{ts}->{min} || '') ) { eval { my $min = parse_timestamp($results->{globals}->{ts}->{min}); my $max = parse_timestamp($results->{globals}->{ts}->{max}); my $diff = unix_timestamp($max) - unix_timestamp($min); $qps = $global_cnt / ($diff || 1); $conc = $results->{globals}->{$args{orderby}}->{sum} / $diff; }; } PTDEBUG && _d('global_cnt:', $global_cnt, 'unique:', scalar keys %{$results->{classes}}, 'qps:', $qps, 'conc:', $conc); my $line = sprintf( '# Overall: %s total, %s unique, %s QPS, %sx concurrency ', shorten($global_cnt, d=>1_000), shorten(scalar keys %{$results->{classes}}, d=>1_000), shorten($qps || 0, d=>1_000), shorten($conc || 0, d=>1_000)); $line .= ('_' x (LINE_LENGTH - length($line) + $self->label_width() - 12)); push @result, $line; if ( my $ts = $results->{globals}->{ts} ) { my $time_range = $self->format_time_range($ts) || "unknown"; push @result, "# Time range: $time_range"; } if ( $results->{globals}->{rate_limit} ) { print "# Rate limits apply\n"; } push @result, $self->make_global_header(); my $attribs = $self->sort_attribs( $ea ); foreach my $type ( qw(num innodb) ) { if ( $type eq 'innodb' && @{$attribs->{$type}} ) { push @result, "# InnoDB:"; }; NUM_ATTRIB: foreach my $attrib ( @{$attribs->{$type}} ) { next unless exists $results->{globals}->{$attrib}; my $store = $results->{globals}->{$attrib}; my $metrics = $ea->stats()->{globals}->{$attrib}; my $func = $attrib =~ m/time|wait$/ ? \µ_t : \&shorten; my @values = ( @{$store}{qw(sum min max)}, $store->{sum} / $store->{cnt}, @{$metrics}{qw(pct_95 stddev median)}, ); @values = map { defined $_ ? $func->($_) : '' } @values; push @result, sprintf $self->{num_format}, $self->make_label($attrib), '', @values; } } if ( @{$attribs->{bool}} ) { push @result, "# Boolean:"; my $printed_bools = 0; BOOL_ATTRIB: foreach my $attrib ( @{$attribs->{bool}} ) { next unless exists $results->{globals}->{$attrib}; my $store = $results->{globals}->{$attrib}; if ( $store->{sum} > 0 ) { push @result, sprintf $self->{bool_format}, $self->make_label($attrib), $self->bool_percents($store); $printed_bools = 1; } } pop @result unless $printed_bools; } return join("\n", map { s/\s+$//; $_ } @result) . "\n"; } sub query_report_values { my ($self, %args) = @_; foreach my $arg ( qw(ea worst orderby groupby) ) { die "I need a $arg argument" unless defined $arg; } my $ea = $args{ea}; my $groupby = $args{groupby}; my $worst = $args{worst}; my $q = $self->Quoter; my $qv = $self->{QueryReview}; my $qr = $self->{QueryRewriter}; my @values; ITEM: foreach my $top_event ( @$worst ) { my $item = $top_event->[0]; my $reason = $args{explain_why} ? $top_event->[1] : ''; my $rank = $top_event->[2]; my $stats = $ea->results->{classes}->{$item}; my $sample = $ea->results->{samples}->{$item}; my $samp_query = $sample->{arg} || ''; my %item_vals = ( item => $item, samp_query => $samp_query, rank => ($rank || 0), reason => $reason, ); my $review_vals; if ( $qv ) { $review_vals = $qv->get_review_info($item); next ITEM if $review_vals->{reviewed_by} && !$self->{options}->{report_all}; for my $col ( $qv->review_cols() ) { push @{$item_vals{review_vals}}, [$col, $review_vals->{$col}]; } } $item_vals{default_db} = $sample->{db} ? $sample->{db} : $stats->{db}->{unq} ? keys %{$stats->{db}->{unq}} : undef; $item_vals{tables} = [$self->{QueryParser}->extract_tables( query => $samp_query, default_db => $item_vals{default_db}, Quoter => $self->Quoter, )]; if ( $samp_query && ($args{variations} && @{$args{variations}}) ) { $item_vals{crc} = crc32($samp_query); } push @values, \%item_vals; } return \@values; } sub query_report { my ( $self, %args ) = @_; my $ea = $args{ea}; my $groupby = $args{groupby}; my $report_values = $self->query_report_values(%args); my $qr = $self->{QueryRewriter}; my $report = ''; if ( $args{print_header} ) { $report .= "# " . ( '#' x 72 ) . "\n" . "# Report grouped by $groupby\n" . '# ' . ( '#' x 72 ) . "\n\n"; } my $attribs = $self->sort_attribs( $ea ); ITEM: foreach my $vals ( @$report_values ) { my $item = $vals->{item}; $report .= "\n" if $vals->{rank} > 1; # space between each event report $report .= $self->event_report( %args, item => $item, sample => $ea->results->{samples}->{$item}, rank => $vals->{rank}, reason => $vals->{reason}, attribs => $attribs, db => $vals->{default_db}, ); if ( $self->{options}->{report_histogram} ) { $report .= $self->chart_distro( %args, attrib => $self->{options}->{report_histogram}, item => $vals->{item}, ); } if ( $vals->{review_vals} ) { $report .= "# Review information\n"; foreach my $elem ( @{$vals->{review_vals}} ) { my ($col, $val) = @$elem; if ( !$val || $val ne '0000-00-00 00:00:00' ) { # issue 202 $report .= sprintf "# %13s: %-s\n", $col, ($val ? $val : ''); } } } if ( $groupby eq 'fingerprint' ) { my $samp_query = $qr->shorten($vals->{samp_query}, $self->{options}->{shorten}) if $self->{options}->{shorten}; PTDEBUG && _d("Fingerprint\n# $vals->{item}\n"); $report .= $self->tables_report($vals->{tables}, \%args); if ( $vals->{crc} ) { $report.= "# CRC " . ($vals->{crc} % 1_000) . "\n"; } my $log_type = $args{log_type} || ''; my $mark = $args{no_v_format} ? '' : '\G'; if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) { if ( $item =~ m/^(?:insert|replace)/ ) { # No EXPLAIN $report .= "$samp_query${mark}\n"; } else { $report .= "# EXPLAIN /*!50100 PARTITIONS*/\n$samp_query${mark}\n"; $report .= $self->explain_report($samp_query, $vals->{default_db}); } } else { $report .= "$samp_query${mark}\n"; my $converted = $qr->convert_to_select($samp_query); if ( $converted && $converted =~ m/^[\(\s]*select/i ) { $report .= "# Converted for EXPLAIN\n# EXPLAIN /*!50100 PARTITIONS*/\n$converted${mark}\n"; } } } else { if ( $groupby eq 'tables' ) { my ( $db, $tbl ) = $self->Quoter->split_unquote($item); $report .= $self->tables_report([ [$db, $tbl] ], \%args); } $report .= "$item\n"; } } return $report; } sub event_report_values { my ($self, %args) = @_; my $ea = $args{ea}; my $item = $args{item}; my $orderby = $args{orderby}; my $results = $ea->results(); my %vals; my $store = $results->{classes}->{$item}; return unless $store; my $global_cnt = $results->{globals}->{$orderby}->{cnt}; my $class_cnt = $store->{$orderby}->{cnt}; my ($qps, $conc) = (0, 0); if ( $global_cnt && $store->{ts} && ($store->{ts}->{max} || '') gt ($store->{ts}->{min} || '') ) { eval { my $min = parse_timestamp($store->{ts}->{min}); my $max = parse_timestamp($store->{ts}->{max}); my $diff = unix_timestamp($max) - unix_timestamp($min); $qps = $class_cnt / $diff; $conc = $store->{$orderby}->{sum} / $diff; }; } $vals{groupby} = $ea->{groupby}; $vals{qps} = $qps || 0; $vals{concurrency} = $conc || 0; $vals{checksum} = make_checksum($item); $vals{pos_in_log} = $results->{samples}->{$item}->{pos_in_log} || 0; $vals{reason} = $args{reason}; $vals{variance_to_mean} = do { my $query_time = $ea->metrics(where => $item, attrib => 'Query_time'); $query_time->{stddev}**2 / ($query_time->{avg} || 1) }; $vals{counts} = { class_cnt => $class_cnt, global_cnt => $global_cnt, }; if ( my $ts = $store->{ts}) { $vals{time_range} = $self->format_time_range($ts) || "unknown"; } my $attribs = $args{attribs}; if ( !$attribs ) { $attribs = $self->sort_attribs( $ea ); } $vals{attributes} = { map { $_ => [] } qw(num innodb bool string) }; foreach my $type ( qw(num innodb) ) { NUM_ATTRIB: foreach my $attrib ( @{$attribs->{$type}} ) { next NUM_ATTRIB unless exists $store->{$attrib}; my $vals = $store->{$attrib}; next unless scalar %$vals; my $pct; my $func = $attrib =~ m/time|wait$/ ? \µ_t : \&shorten; my $metrics = $ea->stats()->{classes}->{$item}->{$attrib}; my @values = ( @{$vals}{qw(sum min max)}, $vals->{sum} / $vals->{cnt}, @{$metrics}{qw(pct_95 stddev median)}, ); @values = map { defined $_ ? $func->($_) : '' } @values; $pct = percentage_of( $vals->{sum}, $results->{globals}->{$attrib}->{sum}); push @{$vals{attributes}{$type}}, [ $attrib, $pct, @values ]; } } if ( @{$attribs->{bool}} ) { BOOL_ATTRIB: foreach my $attrib ( @{$attribs->{bool}} ) { next BOOL_ATTRIB unless exists $store->{$attrib}; my $vals = $store->{$attrib}; next unless scalar %$vals; if ( $vals->{sum} > 0 ) { push @{$vals{attributes}{bool}}, [ $attrib, $self->bool_percents($vals) ]; } } } if ( @{$attribs->{string}} ) { STRING_ATTRIB: foreach my $attrib ( @{$attribs->{string}} ) { next STRING_ATTRIB unless exists $store->{$attrib}; my $vals = $store->{$attrib}; next unless scalar %$vals; push @{$vals{attributes}{string}}, [ $attrib, $vals ]; } } return \%vals; } sub event_report { my ( $self, %args ) = @_; foreach my $arg ( qw(ea item orderby) ) { die "I need a $arg argument" unless defined $args{$arg}; } my $item = $args{item}; my $val = $self->event_report_values(%args); my @result; return "# No such event $item\n" unless $val; my $line = sprintf( '# %s %d: %s QPS, %sx concurrency, ID 0x%s at byte %.f ', ($val->{groupby} eq 'fingerprint' ? 'Query' : 'Item'), $args{rank} || 0, shorten($val->{qps}, d=>1_000), shorten($val->{concurrency}, d=>1_000), $val->{checksum}, $val->{pos_in_log}, ); my $underscores = LINE_LENGTH - length($line) + $self->label_width() - 12; if ( $underscores < 0 ) { $underscores = 0; } $line .= ('_' x $underscores); push @result, $line; if ( $val->{reason} ) { push @result, "# This item is included in the report because it matches " . ($val->{reason} eq 'top' ? '--limit.' : '--outliers.'); } push @result, sprintf("# Scores: V/M = %.2f", $val->{variance_to_mean} ); if ( $val->{time_range} ) { push @result, "# Time range: $val->{time_range}"; } push @result, $self->make_event_header(); push @result, sprintf $self->{num_format}, 'Count', percentage_of($val->{counts}{class_cnt}, $val->{counts}{global_cnt}), $val->{counts}{class_cnt}, map { '' } (1..8); my $attribs = $val->{attributes}; foreach my $type ( qw(num innodb) ) { if ( $type eq 'innodb' && @{$attribs->{$type}} ) { push @result, "# InnoDB:"; }; NUM_ATTRIB: foreach my $attrib ( @{$attribs->{$type}} ) { my ($attrib_name, @vals) = @$attrib; push @result, sprintf $self->{num_format}, $self->make_label($attrib_name), @vals; } } if ( @{$attribs->{bool}} ) { push @result, "# Boolean:"; BOOL_ATTRIB: foreach my $attrib ( @{$attribs->{bool}} ) { my ($attrib_name, @vals) = @$attrib; push @result, sprintf $self->{bool_format}, $self->make_label($attrib_name), @vals; } } if ( @{$attribs->{string}} ) { push @result, "# String:"; STRING_ATTRIB: foreach my $attrib ( @{$attribs->{string}} ) { my ($attrib_name, $vals) = @$attrib; push @result, sprintf $self->{string_format}, $self->make_label($attrib_name), $self->format_string_list($attrib_name, $vals, $val->{counts}{class_cnt}); } } return join("\n", map { s/\s+$//; $_ } @result) . "\n"; } sub chart_distro { my ( $self, %args ) = @_; foreach my $arg ( qw(ea item attrib) ) { die "I need a $arg argument" unless defined $args{$arg}; } my $ea = $args{ea}; my $item = $args{item}; my $attrib = $args{attrib}; my $results = $ea->results(); my $store = $results->{classes}->{$item}->{$attrib}; my $vals = $store->{all}; return "" unless defined $vals && scalar %$vals; my @buck_tens = $ea->buckets_of(10); my @distro = map { 0 } (0 .. 7); my @buckets = map { 0 } (0..999); map { $buckets[$_] = $vals->{$_} } keys %$vals; $vals = \@buckets; # repoint vals from given hashref to our array map { $distro[$buck_tens[$_]] += $vals->[$_] } (1 .. @$vals - 1); my $vals_per_mark; # number of vals represented by 1 #-mark my $max_val = 0; my $max_disp_width = 64; my $bar_fmt = "# %5s%s"; my @distro_labels = qw(1us 10us 100us 1ms 10ms 100ms 1s 10s+); my @results = "# $attrib distribution"; foreach my $n_vals ( @distro ) { $max_val = $n_vals if $n_vals > $max_val; } $vals_per_mark = $max_val / $max_disp_width; foreach my $i ( 0 .. $#distro ) { my $n_vals = $distro[$i]; my $n_marks = $n_vals / ($vals_per_mark || 1); $n_marks = 1 if $n_marks < 1 && $n_vals > 0; my $bar = ($n_marks ? ' ' : '') . '#' x $n_marks; push @results, sprintf $bar_fmt, $distro_labels[$i], $bar; } return join("\n", @results) . "\n"; } sub profile { my ( $self, %args ) = @_; foreach my $arg ( qw(ea worst groupby) ) { die "I need a $arg argument" unless defined $arg; } my $ea = $args{ea}; my $worst = $args{worst}; my $other = $args{other}; my $groupby = $args{groupby}; my $qr = $self->{QueryRewriter}; my $results = $ea->results(); my $total_r = $results->{globals}->{Query_time}->{sum} || 0; my @profiles; foreach my $top_event ( @$worst ) { my $item = $top_event->[0]; my $rank = $top_event->[2]; my $stats = $ea->results->{classes}->{$item}; my $sample = $ea->results->{samples}->{$item}; my $samp_query = $sample->{arg} || ''; my $query_time = $ea->metrics(where => $item, attrib => 'Query_time'); my %profile = ( rank => $rank, r => $stats->{Query_time}->{sum}, cnt => $stats->{Query_time}->{cnt}, sample => $groupby eq 'fingerprint' ? $qr->distill($samp_query, %{$args{distill_args}}) : $item, id => $groupby eq 'fingerprint' ? make_checksum($item) : '', vmr => ($query_time->{stddev}**2) / ($query_time->{avg} || 1), ); push @profiles, \%profile; } my $report = $self->ReportFormatter(); $report->title('Profile'); my @cols = ( { name => 'Rank', right_justify => 1, }, { name => 'Query ID', }, { name => 'Response time', right_justify => 1, }, { name => 'Calls', right_justify => 1, }, { name => 'R/Call', right_justify => 1, }, { name => 'V/M', right_justify => 1, width => 5, }, { name => 'Item', }, ); $report->set_columns(@cols); foreach my $item ( sort { $a->{rank} <=> $b->{rank} } @profiles ) { my $rt = sprintf('%10.4f', $item->{r}); my $rtp = sprintf('%4.1f%%', $item->{r} / ($total_r || 1) * 100); my $rc = sprintf('%8.4f', $item->{r} / $item->{cnt}); my $vmr = sprintf('%4.2f', $item->{vmr}); my @vals = ( $item->{rank}, "0x$item->{id}", "$rt $rtp", $item->{cnt}, $rc, $vmr, $item->{sample}, ); $report->add_line(@vals); } if ( $other && @$other ) { my $misc = { r => 0, cnt => 0, }; foreach my $other_event ( @$other ) { my $item = $other_event->[0]; my $stats = $ea->results->{classes}->{$item}; $misc->{r} += $stats->{Query_time}->{sum}; $misc->{cnt} += $stats->{Query_time}->{cnt}; } my $rt = sprintf('%10.4f', $misc->{r}); my $rtp = sprintf('%4.1f%%', $misc->{r} / ($total_r || 1) * 100); my $rc = sprintf('%8.4f', $misc->{r} / $misc->{cnt}); $report->add_line( "MISC", "0xMISC", "$rt $rtp", $misc->{cnt}, $rc, '0.0', # variance-to-mean ratio is not meaningful here "<".scalar @$other." ITEMS>", ); } return $report->get_report(); } sub prepared { my ( $self, %args ) = @_; foreach my $arg ( qw(ea worst groupby) ) { die "I need a $arg argument" unless defined $arg; } my $ea = $args{ea}; my $worst = $args{worst}; my $groupby = $args{groupby}; my $qr = $self->{QueryRewriter}; my @prepared; # prepared statements my %seen_prepared; # report each PREP-EXEC pair once my $total_r = 0; foreach my $top_event ( @$worst ) { my $item = $top_event->[0]; my $rank = $top_event->[2]; my $stats = $ea->results->{classes}->{$item}; my $sample = $ea->results->{samples}->{$item}; my $samp_query = $sample->{arg} || ''; $total_r += $stats->{Query_time}->{sum}; next unless $stats->{Statement_id} && $item =~ m/^(?:prepare|execute) /; my ($prep_stmt, $prep, $prep_r, $prep_cnt); my ($exec_stmt, $exec, $exec_r, $exec_cnt); if ( $item =~ m/^prepare / ) { $prep_stmt = $item; ($exec_stmt = $item) =~ s/^prepare /execute /; } else { ($prep_stmt = $item) =~ s/^execute /prepare /; $exec_stmt = $item; } if ( !$seen_prepared{$prep_stmt}++ ) { if ( exists $ea->results->{classes}->{$exec_stmt} ) { $exec = $ea->results->{classes}->{$exec_stmt}; $exec_r = $exec->{Query_time}->{sum}; $exec_cnt = $exec->{Query_time}->{cnt}; } else { PTDEBUG && _d('Statement prepared but not executed:', $item); $exec_r = 0; $exec_cnt = 0; } if ( exists $ea->results->{classes}->{$prep_stmt} ) { $prep = $ea->results->{classes}->{$prep_stmt}; $prep_r = $prep->{Query_time}->{sum}; $prep_cnt = scalar keys %{$prep->{Statement_id}->{unq}}, } else { PTDEBUG && _d('Statement executed but not prepared:', $item); $prep_r = 0; $prep_cnt = 0; } push @prepared, { prep_r => $prep_r, prep_cnt => $prep_cnt, exec_r => $exec_r, exec_cnt => $exec_cnt, rank => $rank, sample => $groupby eq 'fingerprint' ? $qr->distill($samp_query, %{$args{distill_args}}) : $item, id => $groupby eq 'fingerprint' ? make_checksum($item) : '', }; } } return unless scalar @prepared; my $report = $self->ReportFormatter(); $report->title('Prepared statements'); $report->set_columns( { name => 'Rank', right_justify => 1, }, { name => 'Query ID', }, { name => 'PREP', right_justify => 1, }, { name => 'PREP Response', right_justify => 1, }, { name => 'EXEC', right_justify => 1, }, { name => 'EXEC Response', right_justify => 1, }, { name => 'Item', }, ); foreach my $item ( sort { $a->{rank} <=> $b->{rank} } @prepared ) { my $exec_rt = sprintf('%10.4f', $item->{exec_r}); my $exec_rtp = sprintf('%4.1f%%',$item->{exec_r}/($total_r || 1) * 100); my $prep_rt = sprintf('%10.4f', $item->{prep_r}); my $prep_rtp = sprintf('%4.1f%%',$item->{prep_r}/($total_r || 1) * 100); $report->add_line( $item->{rank}, "0x$item->{id}", $item->{prep_cnt} || 0, "$prep_rt $prep_rtp", $item->{exec_cnt} || 0, "$exec_rt $exec_rtp", $item->{sample}, ); } return $report->get_report(); } sub make_global_header { my ( $self ) = @_; my @lines; push @lines, sprintf $self->{num_format}, "Attribute", '', @{$self->global_headers()}; push @lines, sprintf $self->{num_format}, (map { "=" x $_ } $self->label_width()), (map { " " x $_ } qw(3)), # no pct column in global header (map { "=" x $_ } qw(7 7 7 7 7 7 7)); return @lines; } sub make_event_header { my ( $self ) = @_; return @{$self->{event_header_lines}} if $self->{event_header_lines}; my @lines; push @lines, sprintf $self->{num_format}, "Attribute", @{$self->event_headers()}; push @lines, sprintf $self->{num_format}, map { "=" x $_ } ($self->label_width(), qw(3 7 7 7 7 7 7 7)); $self->{event_header_lines} = \@lines; return @lines; } sub make_label { my ( $self, $val ) = @_; return '' unless $val; $val =~ s/_/ /g; if ( $val =~ m/^InnoDB/ ) { $val =~ s/^InnoDB //; $val = $val eq 'trx id' ? "InnoDB trxID" : substr($val, 0, $self->label_width()); } $val = $val eq 'user' ? 'Users' : $val eq 'db' ? 'Databases' : $val eq 'Query time' ? 'Exec time' : $val eq 'host' ? 'Hosts' : $val eq 'Error no' ? 'Errors' : $val eq 'bytes' ? 'Query size' : $val eq 'Tmp disk tables' ? 'Tmp disk tbl' : $val eq 'Tmp table sizes' ? 'Tmp tbl size' : substr($val, 0, $self->label_width); return $val; } sub bool_percents { my ( $self, $vals ) = @_; my $p_true = percentage_of($vals->{sum}, $vals->{cnt}); my $p_false = percentage_of(($vals->{cnt} - $vals->{sum}), $vals->{cnt}); return $p_true, $p_false; } sub format_string_list { my ( $self, $attrib, $vals, $class_cnt ) = @_; if ( !exists $vals->{unq} ) { return ($vals->{cnt}); } my $show_all = $self->show_all(); my $cnt_for = $vals->{unq}; if ( 1 == keys %$cnt_for ) { my ($str) = keys %$cnt_for; $str = substr($str, 0, LINE_LENGTH - 30) . '...' if length $str > LINE_LENGTH - 30; return $str; } my $line = ''; my @top = sort { $cnt_for->{$b} <=> $cnt_for->{$a} || $a cmp $b } keys %$cnt_for; my $i = 0; foreach my $str ( @top ) { my $print_str; if ( $str =~ m/(?:\d+\.){3}\d+/ ) { $print_str = $str; # Do not shorten IP addresses. } elsif ( length $str > MAX_STRING_LENGTH ) { $print_str = substr($str, 0, MAX_STRING_LENGTH) . '...'; } else { $print_str = $str; } my $p = percentage_of($cnt_for->{$str}, $class_cnt); $print_str .= " ($cnt_for->{$str}/$p%)"; if ( !$show_all->{$attrib} ) { last if (length $line) + (length $print_str) > LINE_LENGTH - 27; } $line .= "$print_str, "; $i++; } $line =~ s/, $//; if ( $i < @top ) { $line .= "... " . (@top - $i) . " more"; } return $line; } sub sort_attribs { my ( $self, $ea ) = @_; my $attribs = $ea->get_attributes(); return unless $attribs && @$attribs; PTDEBUG && _d("Sorting attribs:", @$attribs); my @num_order = qw( Query_time Exec_orig_time Transmit_time Lock_time Rows_sent Rows_examined Rows_affected Rows_read Bytes_sent Merge_passes Tmp_tables Tmp_disk_tables Tmp_table_sizes bytes ); my $i = 0; my %num_order = map { $_ => $i++ } @num_order; my (@num, @innodb, @bool, @string); ATTRIB: foreach my $attrib ( @$attribs ) { next if $self->{hidden_attrib}->{$attrib}; my $type = $ea->type_for($attrib) || 'string'; if ( $type eq 'num' ) { if ( $attrib =~ m/^InnoDB_/ ) { push @innodb, $attrib; } else { push @num, $attrib; } } elsif ( $type eq 'bool' ) { push @bool, $attrib; } elsif ( $type eq 'string' ) { push @string, $attrib; } else { PTDEBUG && _d("Unknown attrib type:", $type, "for", $attrib); } } @num = sort { pref_sort($a, $num_order{$a}, $b, $num_order{$b}) } @num; @innodb = sort { uc $a cmp uc $b } @innodb; @bool = sort { uc $a cmp uc $b } @bool; @string = sort { uc $a cmp uc $b } @string; return { num => \@num, innodb => \@innodb, string => \@string, bool => \@bool, }; } sub pref_sort { my ( $attrib_a, $order_a, $attrib_b, $order_b ) = @_; if ( !defined $order_a && !defined $order_b ) { return $attrib_a cmp $attrib_b; } if ( defined $order_a && defined $order_b ) { return $order_a <=> $order_b; } if ( !defined $order_a ) { return 1; } else { return -1; } } sub tables_report { my ( $self, $tables_ref, $args_ref ) = @_; return '' unless @$tables_ref; my $q = $self->Quoter(); my $tables = ""; my $mark = $args_ref->{no_v_format} ? '' : '\G'; foreach my $db_tbl ( @$tables_ref ) { my ( $db, $tbl ) = @$db_tbl; $tables .= '# SHOW TABLE STATUS' . ($db ? " FROM `$db`" : '') . " LIKE '$tbl'${mark}\n"; $tables .= "# SHOW CREATE TABLE " . $q->quote(grep { $_ } @$db_tbl) . "${mark}\n"; } return $tables ? "# Tables\n$tables" : "# No tables\n"; } sub explain_report { my ( $self, $query, $db ) = @_; return '' unless $query; my $dbh = $self->{dbh}; my $q = $self->Quoter(); my $qp = $self->{QueryParser}; return '' unless $dbh && $q && $qp; my $explain = ''; eval { if ( !$qp->has_derived_table($query) ) { if ( $db ) { PTDEBUG && _d($dbh, "USE", $db); $dbh->do("USE " . $q->quote($db)); } my $sth = $dbh->prepare("EXPLAIN /*!50100 PARTITIONS */ $query"); $sth->execute(); my $i = 1; while ( my @row = $sth->fetchrow_array() ) { $explain .= "# *************************** $i. " . "row ***************************\n"; foreach my $j ( 0 .. $#row ) { $explain .= sprintf "# %13s: %s\n", $sth->{NAME}->[$j], defined $row[$j] ? $row[$j] : 'NULL'; } $i++; # next row number } } }; if ( $EVAL_ERROR ) { PTDEBUG && _d("EXPLAIN failed:", $query, $EVAL_ERROR); } return $explain ? $explain : "# EXPLAIN failed: $EVAL_ERROR"; } sub format_time_range { my ( $self, $vals ) = @_; my $min = parse_timestamp($vals->{min} || ''); my $max = parse_timestamp($vals->{max} || ''); if ( $min && $max && $min eq $max ) { return "all events occurred at $min"; } my ($min_day) = split(' ', $min) if $min; my ($max_day) = split(' ', $max) if $max; if ( ($min_day || '') eq ($max_day || '') ) { (undef, $max) = split(' ', $max); } return $min && $max ? "$min to $max" : ''; } 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 QueryReportFormatter package # ########################################################################### # ########################################################################### # JSONReportFormatter 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/JSONReportFormatter.pm # t/lib/JSONReportFormatter.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package JSONReportFormatter; use Lmo; use List::Util qw(sum); use Transformers qw(make_checksum parse_timestamp); use constant PTDEBUG => $ENV{PTDEBUG} || 0; my $have_json = eval { require JSON }; our $pretty_json = $ENV{PTTEST_PRETTY_JSON} || 0; our $sorted_json = $ENV{PTTEST_PRETTY_JSON} || 0; extends qw(QueryReportFormatter); has 'QueryRewriter' => ( is => 'ro', isa => 'Object', required => 1, ); has 'QueryParser' => ( is => 'ro', isa => 'Object', required => 1, ); has 'Quoter' => ( is => 'ro', isa => 'Object', required => 1, ); has _json => ( is => 'ro', init_arg => undef, builder => '_build_json', ); has 'max_query_length' => ( is => 'rw', isa => 'Int', required => 0, default => sub { return 10_000; }, # characters, not bytes ); has 'max_fingerprint_length' => ( is => 'rw', isa => 'Int', required => 0, default => sub { return 5_000; }, # characters, not bytes ); sub _build_json { return unless $have_json; return JSON->new->utf8 ->pretty($pretty_json) ->canonical($sorted_json); } sub encode_json { my ($self, $encode) = @_; if ( my $json = $self->_json ) { return $json->encode($encode); } else { return Transformers::encode_json($encode); } } override [qw(rusage date hostname files header profile prepared)] => sub { return; }; override event_report => sub { my ($self, %args) = @_; return $self->event_report_values(%args); }; override query_report => sub { my ($self, %args) = @_; foreach my $arg ( qw(ea worst orderby groupby) ) { die "I need a $arg argument" unless defined $arg; } my $ea = $args{ea}; my $worst = $args{worst}; my $orderby = $args{orderby}; my $groupby = $args{groupby}; my $results = $ea->results(); my @attribs = @{$ea->get_attributes()}; my $q = $self->Quoter; my $qr = $self->QueryRewriter; my $global_data = { metrics => {}, files => $args{files}, ($args{resume} && scalar keys %{$args{resume}} ? (resume => $args{resume}) : ()), }; my $global_cnt = $results->{globals}->{$orderby}->{cnt} || 0; my $global_unq = scalar keys %{$results->{classes}}; my ($qps, $conc) = (0, 0); if ( $global_cnt && $results->{globals}->{ts} && ($results->{globals}->{ts}->{max} || '') gt ($results->{globals}->{ts}->{min} || '') ) { eval { my $min = parse_timestamp($results->{globals}->{ts}->{min}); my $max = parse_timestamp($results->{globals}->{ts}->{max}); my $diff = unix_timestamp($max) - unix_timestamp($min); $qps = $global_cnt / ($diff || 1); $conc = $results->{globals}->{$orderby}->{sum} / $diff; }; } $global_data->{query_count} = $global_cnt; $global_data->{unique_query_count} = $global_unq; $global_data->{queries_per_second} = $qps if $qps; $global_data->{concurrency} = $conc if $conc; if ( exists $results->{globals}->{rate_limit} ) { my $rate_limit = $results->{globals}->{rate_limit}->{min} || ''; my ($type, $limit) = $rate_limit =~ m/^(\w+):(\d+)$/; if ( $type && $limit ) { $global_data->{rate_limit} = { type => $type, limit => int($limit), }; } else { $global_data->{rate_limit}->{error} = "Invalid rate limit: $rate_limit"; } if ( ($results->{globals}->{rate_limit}->{min} || '') ne ($results->{globals}->{rate_limit}->{max} || '') ) { $global_data->{rate_limit}->{diff} = 1; } } my %hidden_attrib = ( arg => 1, fingerprint => 1, pos_in_log => 1, ts => 1, ); foreach my $attrib ( grep { !$hidden_attrib{$_} } @attribs ) { my $type = $ea->type_for($attrib) || 'string'; next if $type eq 'string'; next unless exists $results->{globals}->{$attrib}; my $store = $results->{globals}->{$attrib}; my $metrics = $ea->stats()->{globals}->{$attrib}; my $int = $attrib =~ m/(?:time|wait)$/ ? 0 : 1; my $real_attrib = $attrib eq 'bytes' ? 'Query_length' : $attrib; if ( $type eq 'num' ) { foreach my $m ( qw(sum min max) ) { if ( $int ) { $global_data->{metrics}->{$real_attrib}->{$m} = sprintf('%d', $store->{$m} || 0); } else { # microsecond $global_data->{metrics}->{$real_attrib}->{$m} = sprintf('%.6f', $store->{$m} || 0); } } foreach my $m ( qw(pct_95 stddev median) ) { if ( $int ) { $global_data->{metrics}->{$real_attrib}->{$m} = sprintf('%d', $metrics->{$m} || 0); } else { # microsecond $global_data->{metrics}->{$real_attrib}->{$m} = sprintf('%.6f', $metrics->{$m} || 0); } } if ( $int ) { $global_data->{metrics}->{$real_attrib}->{avg} = sprintf('%d', $store->{sum} / $store->{cnt}); } else { $global_data->{metrics}->{$real_attrib}->{avg} = sprintf('%.6f', $store->{sum} / $store->{cnt}); } } elsif ( $type eq 'bool' ) { my $store = $results->{globals}->{$real_attrib}; $global_data->{metrics}->{$real_attrib}->{cnt} = sprintf('%d', $store->{sum}); } } my @classes; foreach my $worst_info ( @$worst ) { my $item = $worst_info->[0]; my $stats = $ea->results->{classes}->{$item}; my $sample = $ea->results->{samples}->{$item}; my $all_log_pos = $ea->{result_classes}->{$item}->{pos_in_log}->{all}; my $times_seen = sum values %$all_log_pos; my $distill = $groupby eq 'fingerprint' ? $qr->distill($sample->{arg}) : undef; my $fingerprint = substr($item, 0, $self->max_fingerprint_length); my $checksum = make_checksum($item); my $class = { checksum => $checksum, fingerprint => $fingerprint, distillate => $distill, attribute => $groupby, query_count => $times_seen, $args{anon} ? () : ( example => { query => substr($sample->{arg}, 0, $self->max_query_length), ts => $sample->{ts} ? parse_timestamp($sample->{ts}) : undef, Query_time => $sample->{Query_time}, }, ), }; my %metrics; foreach my $attrib ( @attribs ) { my $real_attrib = $attrib eq 'bytes' ? 'Query_length' : $attrib; next if $real_attrib eq 'Rows_affected' && $distill && $distill =~ m/^(?:SELECT|SHOW|SET|ADMIN)/; $metrics{$real_attrib} = $ea->metrics( attrib => $attrib, where => $item, ); } foreach my $attrib ( keys %metrics ) { if ( ! grep { $_ } values %{$metrics{$attrib}} ) { delete $metrics{$attrib}; next; } delete $metrics{pos_in_log}; delete $metrics{$attrib}->{cnt}; if ($attrib eq 'ts') { my $ts = delete $metrics{ts}; foreach my $thing ( qw(min max) ) { next unless defined $ts && defined $ts->{$thing}; $ts->{$thing} = parse_timestamp($ts->{$thing}); } $class->{ts_min} = $ts->{min}; $class->{ts_max} = $ts->{max}; } else { my $type = $attrib eq 'Query_length' ? 'num' : $ea->type_for($attrib) || 'string'; if ( $type eq 'string' ) { $metrics{$attrib} = { value => $metrics{$attrib}{max} }; } elsif ( $type eq 'num' ) { foreach my $value ( values %{$metrics{$attrib}} ) { next unless defined $value; if ( $attrib =~ m/_(?:time|wait)$/ ) { $value = sprintf('%.6f', $value); } else { $value = sprintf('%d', $value); } } } elsif ( $type eq 'bool' ) { $metrics{$attrib} = { yes => sprintf('%d', $metrics{$attrib}->{sum}), }; } } } my @tables; if ( $groupby eq 'fingerprint' ) { my $default_db = $sample->{db} ? $sample->{db} : $stats->{db}->{unq} ? keys %{$stats->{db}->{unq}} : undef; my @table_names = $self->QueryParser->extract_tables( query => $sample->{arg} || '', default_db => $default_db, Quoter => $q, ); my $mark = $args{no_v_format} ? '' : '\G'; foreach my $db_tbl ( @table_names ) { my ( $db, $tbl ) = @$db_tbl; my $status = 'SHOW TABLE STATUS' . ($db ? " FROM `$db`" : '') . " LIKE '$tbl'${mark}"; my $create = "SHOW CREATE TABLE " . $q->quote(grep { $_ } @$db_tbl) . ${mark}; push @tables, { status => $status, create => $create }; } if ( !$args{anon} ) { if ( $item =~ m/^(?:[\(\s]*select|insert|replace)/ ) { if ( $item =~ m/^(?:insert|replace)/ ) { } else { } } else { my $converted = $qr->convert_to_select( $sample->{arg} || '', ); if ( $converted && $converted =~ m/^[\(\s]*select/i ) { $class->{example}->{as_select} = $converted; } } } } my $vals = $stats->{Query_time}->{all}; if ( defined $vals && scalar %$vals ) { my @buck_tens = $ea->buckets_of(10); my @distro = map { 0 } (0 .. 7); my @buckets = map { 0 } (0..999); map { $buckets[$_] = $vals->{$_} } keys %$vals; $vals = \@buckets; # repoint vals from given hashref to our array map { $distro[$buck_tens[$_]] += $vals->[$_] } (1 .. @$vals - 1); $class->{histograms}->{Query_time} = \@distro; } # histogram $class->{metrics} = \%metrics; if ( @tables ) { $class->{tables} = \@tables; } push @classes, $class; } my $data = { global => $global_data, classes => \@classes, }; my $json = $self->encode_json($data); $json .= "\n" unless $json =~ /\n\Z/; return $json; }; no Lmo; 1; } # ########################################################################### # End JSONReportFormatter package # ########################################################################### # ########################################################################### # EventTimeline 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/EventTimeline.pm # t/lib/EventTimeline.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package EventTimeline; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; Transformers->import(qw(parse_timestamp secs_to_time unix_timestamp)); use constant KEY => 0; use constant CNT => 1; use constant ATT => 2; sub new { my ( $class, %args ) = @_; foreach my $arg ( qw(groupby attributes) ) { die "I need a $arg argument" unless $args{$arg}; } my %is_groupby = map { $_ => 1 } @{$args{groupby}}; return bless { groupby => $args{groupby}, attributes => [ grep { !$is_groupby{$_} } @{$args{attributes}} ], results => [], }, $class; } sub reset_aggregated_data { my ( $self ) = @_; $self->{results} = []; } sub aggregate { my ( $self, $event ) = @_; my $handler = $self->{handler}; if ( !$handler ) { $handler = $self->make_handler($event); $self->{handler} = $handler; } return unless $handler; $handler->($event); } sub results { my ( $self ) = @_; return $self->{results}; } sub make_handler { my ( $self, $event ) = @_; my $float_re = qr{[+-]?(?:(?=\d|[.])\d*(?:[.])\d{0,})?(?:[E](?:[+-]?\d+)|)}i; my @lines; # lines of code for the subroutine foreach my $attrib ( @{$self->{attributes}} ) { my ($val) = $event->{$attrib}; next unless defined $val; # Can't decide type if it's undef. my $type = $val =~ m/^(?:\d+|$float_re)$/o ? 'num' : $val =~ m/^(?:Yes|No)$/ ? 'bool' : 'string'; PTDEBUG && _d('Type for', $attrib, 'is', $type, '(sample:', $val, ')'); $self->{type_for}->{$attrib} = $type; push @lines, ( "\$val = \$event->{$attrib};", 'defined $val && do {', "# type: $type", "\$store = \$last->[ATT]->{$attrib} ||= {};", ); if ( $type eq 'bool' ) { push @lines, q{$val = $val eq 'Yes' ? 1 : 0;}; $type = 'num'; } my $op = $type eq 'num' ? '<' : 'lt'; push @lines, ( '$store->{min} = $val if !defined $store->{min} || $val ' . $op . ' $store->{min};', ); $op = ($type eq 'num') ? '>' : 'gt'; push @lines, ( '$store->{max} = $val if !defined $store->{max} || $val ' . $op . ' $store->{max};', ); if ( $type eq 'num' ) { push @lines, '$store->{sum} += $val;'; } push @lines, '};'; } unshift @lines, ( 'sub {', 'my ( $event ) = @_;', 'my ($val, $last, $store);', # NOTE: define all variables here '$last = $results->[-1];', 'if ( !$last || ' . join(' || ', map { "\$last->[KEY]->[$_] ne (\$event->{$self->{groupby}->[$_]} || 0)" } (0 .. @{$self->{groupby}} -1)) . ' ) {', ' $last = [[' . join(', ', map { "(\$event->{$self->{groupby}->[$_]} || 0)" } (0 .. @{$self->{groupby}} -1)) . '], 0, {} ];', ' push @$results, $last;', '}', '++$last->[CNT];', ); push @lines, '}'; my $results = $self->{results}; # Referred to by the eval my $code = join("\n", @lines); $self->{code} = $code; PTDEBUG && _d('Timeline handler:', $code); my $sub = eval $code; die if $EVAL_ERROR; return $sub; } sub report { my ( $self, $results, $callback ) = @_; $callback->("# " . ('#' x 72) . "\n"); $callback->("# " . join(',', @{$self->{groupby}}) . " report\n"); $callback->("# " . ('#' x 72) . "\n"); foreach my $res ( @$results ) { my $t; my @vals; if ( ($t = $res->[ATT]->{ts}) && $t->{min} ) { my $min = parse_timestamp($t->{min}); push @vals, $min; if ( $t->{max} && $t->{max} gt $t->{min} ) { my $max = parse_timestamp($t->{max}); my $diff = secs_to_time(unix_timestamp($max) - unix_timestamp($min)); push @vals, $diff; } else { push @vals, '0:00'; } } else { push @vals, ('', ''); } $callback->(sprintf("# %19s %7s %3d %s\n", @vals, $res->[CNT], $res->[KEY]->[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 EventTimeline package # ########################################################################### # ########################################################################### # QueryParser 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/QueryParser.pm # t/lib/QueryParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryParser; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; our $tbl_ident = qr/(?:`[^`]+`|\w+)(?:\.(?:`[^`]+`|\w+))?/; our $tbl_regex = qr{ \b(?:FROM|JOIN|(?get_tables($select); } my ($tbl) = $query =~ m/TABLE\s+($tbl_ident)(\s+.*)?/i; PTDEBUG && _d('Matches table:', $tbl); return ($tbl); } $query =~ s/(?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN|DELAYED)\s+/ /ig; if ( $query =~ s/^\s*LOCK TABLES\s+//i ) { PTDEBUG && _d('Special table type: LOCK TABLES'); $query =~ s/\s+(?:READ(?:\s+LOCAL)?|WRITE)\s*//gi; PTDEBUG && _d('Locked tables:', $query); $query = "FROM $query"; } $query =~ s/\\["']//g; # quoted strings $query =~ s/".*?"/?/sg; # quoted strings $query =~ s/'.*?'/?/sg; # quoted strings if ( $query =~ m/\A\s*(?:INSERT|REPLACE)(?!\s+INTO)/i ) { $query =~ s/\A\s*((?:INSERT|REPLACE))\s+/$1 INTO /i; } if ( $query =~ m/\A\s*LOAD DATA/i ) { my ($tbl) = $query =~ m/INTO TABLE\s+(\S+)/i; return $tbl; } my @tables; foreach my $tbls ( $query =~ m/$tbl_regex/gio ) { PTDEBUG && _d('Match tables:', $tbls); next if $tbls =~ m/\ASELECT\b/i; foreach my $tbl ( split(',', $tbls) ) { $tbl =~ s/\s*($tbl_ident)(\s+.*)?/$1/gio; if ( $tbl !~ m/[a-zA-Z]/ ) { PTDEBUG && _d('Skipping suspicious table name:', $tbl); next; } push @tables, $tbl; } } return @tables; } sub has_derived_table { my ( $self, $query ) = @_; my $match = $query =~ m/$has_derived/; PTDEBUG && _d($query, 'has ' . ($match ? 'a' : 'no') . ' derived table'); return $match; } sub get_aliases { my ( $self, $query, $list ) = @_; my $result = { DATABASE => {}, TABLE => {}, }; return $result unless $query; $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig; $query =~ s/ (?:INNER|OUTER|CROSS|LEFT|RIGHT|NATURAL)//ig; my @tbl_refs; my ($tbl_refs, $from) = $query =~ m{ ( (FROM|INTO|UPDATE)\b\s* # Keyword before table refs .+? # Table refs ) (?:\s+|\z) # If the query does not end with the table (?:WHERE|ORDER|LIMIT|HAVING|SET|VALUES|\z) # Keyword after table refs }ix; if ( $tbl_refs ) { if ( $query =~ m/^(?:INSERT|REPLACE)/i ) { $tbl_refs =~ s/\([^\)]+\)\s*//; } PTDEBUG && _d('tbl refs:', $tbl_refs); my $before_tbl = qr/(?:,|JOIN|\s|$from)+/i; my $after_tbl = qr/(?:,|JOIN|ON|USING|\z)/i; $tbl_refs =~ s/ = /=/g; while ( $tbl_refs =~ m{ $before_tbl\b\s* ( ($tbl_ident) (?:\s+ (?:AS\s+)? (\w+))? ) \s*$after_tbl }xgio ) { my ( $tbl_ref, $db_tbl, $alias ) = ($1, $2, $3); PTDEBUG && _d('Match table:', $tbl_ref); push @tbl_refs, $tbl_ref; $alias = $self->trim_identifier($alias); if ( $tbl_ref =~ m/^AS\s+\w+/i ) { PTDEBUG && _d('Subquery', $tbl_ref); $result->{TABLE}->{$alias} = undef; next; } my ( $db, $tbl ) = $db_tbl =~ m/^(?:(.*?)\.)?(.*)/; $db = $self->trim_identifier($db); $tbl = $self->trim_identifier($tbl); $result->{TABLE}->{$alias || $tbl} = $tbl; $result->{DATABASE}->{$tbl} = $db if $db; } } else { PTDEBUG && _d("No tables ref in", $query); } if ( $list ) { return \@tbl_refs; } else { return $result; } } sub split { my ( $self, $query ) = @_; return unless $query; $query = $self->clean_query($query); PTDEBUG && _d('Splitting', $query); my $verbs = qr{SELECT|INSERT|UPDATE|DELETE|REPLACE|UNION|CREATE}i; my @split_statements = grep { $_ } split(m/\b($verbs\b(?!(?:\s*\()))/io, $query); my @statements; if ( @split_statements == 1 ) { push @statements, $query; } else { for ( my $i = 0; $i <= $#split_statements; $i += 2 ) { push @statements, $split_statements[$i].$split_statements[$i+1]; if ( $statements[-2] && $statements[-2] =~ m/on duplicate key\s+$/i ) { $statements[-2] .= pop @statements; } } } PTDEBUG && _d('statements:', map { $_ ? "<$_>" : 'none' } @statements); return @statements; } sub clean_query { my ( $self, $query ) = @_; return unless $query; $query =~ s!/\*.*?\*/! !g; # Remove /* comment blocks */ $query =~ s/^\s+//; # Remove leading spaces $query =~ s/\s+$//; # Remove trailing spaces $query =~ s/\s{2,}/ /g; # Remove extra spaces return $query; } sub split_subquery { my ( $self, $query ) = @_; return unless $query; $query = $self->clean_query($query); $query =~ s/;$//; my @subqueries; my $sqno = 0; # subquery number my $pos = 0; while ( $query =~ m/(\S+)(?:\s+|\Z)/g ) { $pos = pos($query); my $word = $1; PTDEBUG && _d($word, $sqno); if ( $word =~ m/^\(?SELECT\b/i ) { my $start_pos = $pos - length($word) - 1; if ( $start_pos ) { $sqno++; PTDEBUG && _d('Subquery', $sqno, 'starts at', $start_pos); $subqueries[$sqno] = { start_pos => $start_pos, end_pos => 0, len => 0, words => [$word], lp => 1, # left parentheses rp => 0, # right parentheses done => 0, }; } else { PTDEBUG && _d('Main SELECT at pos 0'); } } else { next unless $sqno; # next unless we're in a subquery PTDEBUG && _d('In subquery', $sqno); my $sq = $subqueries[$sqno]; if ( $sq->{done} ) { PTDEBUG && _d('This subquery is done; SQL is for', ($sqno - 1 ? "subquery $sqno" : "the main SELECT")); next; } push @{$sq->{words}}, $word; my $lp = ($word =~ tr/\(//) || 0; my $rp = ($word =~ tr/\)//) || 0; PTDEBUG && _d('parentheses left', $lp, 'right', $rp); if ( ($sq->{lp} + $lp) - ($sq->{rp} + $rp) == 0 ) { my $end_pos = $pos - 1; PTDEBUG && _d('Subquery', $sqno, 'ends at', $end_pos); $sq->{end_pos} = $end_pos; $sq->{len} = $end_pos - $sq->{start_pos}; } } } for my $i ( 1..$#subqueries ) { my $sq = $subqueries[$i]; next unless $sq; $sq->{sql} = join(' ', @{$sq->{words}}); substr $query, $sq->{start_pos} + 1, # +1 for ( $sq->{len} - 1, # -1 for ) "__subquery_$i"; } return $query, map { $_->{sql} } grep { defined $_ } @subqueries; } sub query_type { my ( $self, $query, $qr ) = @_; my ($type, undef) = $qr->distill_verbs($query); my $rw; if ( $type =~ m/^SELECT\b/ ) { $rw = 'read'; } elsif ( $type =~ m/^$data_manip_stmts\b/ || $type =~ m/^$data_def_stmts\b/ ) { $rw = 'write' } return { type => $type, rw => $rw, } } sub get_columns { my ( $self, $query ) = @_; my $cols = []; return $cols unless $query; my $cols_def; if ( $query =~ m/^SELECT/i ) { $query =~ s/ ^SELECT\s+ (?:ALL |DISTINCT |DISTINCTROW |HIGH_PRIORITY |STRAIGHT_JOIN |SQL_SMALL_RESULT |SQL_BIG_RESULT |SQL_BUFFER_RESULT |SQL_CACHE |SQL_NO_CACHE |SQL_CALC_FOUND_ROWS )\s+ /SELECT /xgi; ($cols_def) = $query =~ m/^SELECT\s+(.+?)\s+FROM/i; } elsif ( $query =~ m/^(?:INSERT|REPLACE)/i ) { ($cols_def) = $query =~ m/\(([^\)]+)\)\s*VALUE/i; } PTDEBUG && _d('Columns:', $cols_def); if ( $cols_def ) { @$cols = split(',', $cols_def); map { my $col = $_; $col = s/^\s+//g; $col = s/\s+$//g; $col; } @$cols; } return $cols; } sub parse { my ( $self, $query ) = @_; return unless $query; my $parsed = {}; $query =~ s/\n/ /g; $query = $self->clean_query($query); $parsed->{query} = $query, $parsed->{tables} = $self->get_aliases($query, 1); $parsed->{columns} = $self->get_columns($query); my ($type) = $query =~ m/^(\w+)/; $parsed->{type} = lc $type; $parsed->{sub_queries} = []; return $parsed; } sub extract_tables { my ( $self, %args ) = @_; my $query = $args{query}; my $default_db = $args{default_db}; my $q = $self->{Quoter} || $args{Quoter}; return unless $query; PTDEBUG && _d('Extracting tables'); my @tables; my %seen; foreach my $db_tbl ( $self->get_tables($query) ) { next unless $db_tbl; next if $seen{$db_tbl}++; # Unique-ify for issue 337. my ( $db, $tbl ) = $q->split_unquote($db_tbl); push @tables, [ $db || $default_db, $tbl ]; } return @tables; } sub trim_identifier { my ($self, $str) = @_; return unless defined $str; $str =~ s/`//g; $str =~ s/^\s+//; $str =~ s/\s+$//; return $str; } 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 QueryParser 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 # ########################################################################### # ########################################################################### # QueryReview 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/QueryReview.pm # t/lib/QueryReview.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryReview; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; Transformers->import(qw(make_checksum parse_timestamp)); my %basic_cols = map { $_ => 1 } qw(checksum fingerprint sample first_seen last_seen reviewed_by reviewed_on comments); my %skip_cols = map { $_ => 1 } qw(fingerprint sample checksum); sub new { my ( $class, %args ) = @_; foreach my $arg ( qw(dbh db_tbl tbl_struct quoter) ) { die "I need a $arg argument" unless $args{$arg}; } foreach my $col ( keys %basic_cols ) { die "Query review table $args{db_tbl} does not have a $col column" unless $args{tbl_struct}->{is_col}->{$col}; } my $now = defined $args{ts_default} ? $args{ts_default} : 'NOW()'; my $sql = <<" SQL"; INSERT INTO $args{db_tbl} (checksum, fingerprint, sample, first_seen, last_seen) VALUES(CONV(?, 16, 10), ?, ?, COALESCE(?, $now), COALESCE(?, $now)) ON DUPLICATE KEY UPDATE first_seen = IF( first_seen IS NULL, COALESCE(?, $now), LEAST(first_seen, COALESCE(?, $now))), last_seen = IF( last_seen IS NULL, COALESCE(?, $now), GREATEST(last_seen, COALESCE(?, $now))) SQL PTDEBUG && _d('SQL to insert into review table:', $sql); my $insert_sth = $args{dbh}->prepare($sql); my @review_cols = grep { !$skip_cols{$_} } @{$args{tbl_struct}->{cols}}; $sql = "SELECT " . join(', ', map { $args{quoter}->quote($_) } @review_cols) . ", CONV(checksum, 10, 16) AS checksum_conv FROM $args{db_tbl}" . " WHERE checksum=CONV(?, 16, 10)"; PTDEBUG && _d('SQL to select from review table:', $sql); my $select_sth = $args{dbh}->prepare($sql); my $self = { dbh => $args{dbh}, db_tbl => $args{db_tbl}, insert_sth => $insert_sth, select_sth => $select_sth, tbl_struct => $args{tbl_struct}, quoter => $args{quoter}, ts_default => $now, }; return bless $self, $class; } sub get_review_info { my ( $self, $id ) = @_; $self->{select_sth}->execute(make_checksum($id)); my $review_vals = $self->{select_sth}->fetchall_arrayref({}); if ( $review_vals && @$review_vals == 1 ) { return $review_vals->[0]; } return undef; } sub set_review_info { my ( $self, %args ) = @_; $self->{insert_sth}->execute( make_checksum($args{fingerprint}), @args{qw(fingerprint sample)}, map { $args{$_} ? parse_timestamp($args{$_}) : undef } qw(first_seen last_seen first_seen first_seen last_seen last_seen)); } sub review_cols { my ( $self ) = @_; return grep { !$skip_cols{$_} } @{$self->{tbl_struct}->{cols}}; } 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 QueryReview package # ########################################################################### # ########################################################################### # QueryHistory 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/QueryHistory.pm # t/lib/QueryHistory.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryHistory; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; use Lmo; use Quoter; use Transformers qw(make_checksum parse_timestamp); has history_dbh => ( is => 'ro', required => 1, ); has history_sth => ( is => 'rw', ); has history_metrics => ( is => 'rw', isa => 'ArrayRef', ); has column_pattern => ( is => 'ro', isa => 'Regexp', required => 1, ); has ts_default => ( is => 'ro', isa => 'Str', default => sub { 'NOW()' }, ); sub set_history_options { my ( $self, %args ) = @_; foreach my $arg ( qw(table tbl_struct) ) { die "I need a $arg argument" unless $args{$arg}; } my $col_pat = $self->column_pattern(); my @cols; my @metrics; foreach my $col ( @{$args{tbl_struct}->{cols}} ) { my ( $attr, $metric ) = $col =~ m/$col_pat/; next unless $attr && $metric; $attr = ucfirst $attr if $attr =~ m/_/; $attr = 'Filesort' if $attr eq 'filesort'; $attr =~ s/^Qc_hit/QC_Hit/; # Qc_hit is really QC_Hit $attr =~ s/^Innodb/InnoDB/g; # Innodb is really InnoDB $attr =~ s/_io_/_IO_/g; # io is really IO push @cols, $col; push @metrics, [$attr, $metric]; } my $ts_default = $self->ts_default; my $sql = "REPLACE INTO $args{table}(" . join(', ', map { Quoter->quote($_) } ('checksum', 'sample', @cols)) . ') VALUES (CONV(?, 16, 10), ?' . (@cols ? ', ' : '') # issue 1265 . join(', ', map { $_ eq 'ts_min' || $_ eq 'ts_max' ? "COALESCE(?, $ts_default)" : '?' } @cols) . ')'; PTDEBUG && _d($sql); $self->history_sth($self->history_dbh->prepare($sql)); $self->history_metrics(\@metrics); return; } sub set_review_history { my ( $self, $id, $sample, %data ) = @_; foreach my $thing ( qw(min max) ) { next unless defined $data{ts} && defined $data{ts}->{$thing}; $data{ts}->{$thing} = parse_timestamp($data{ts}->{$thing}); } $self->history_sth->execute( make_checksum($id), $sample, map { $data{$_->[0]}->{$_->[1]} } @{$self->history_metrics}); } 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 QueryHistory 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 # ########################################################################### # ########################################################################### # BinaryLogParser 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/BinaryLogParser.pm # t/lib/BinaryLogParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package BinaryLogParser; 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; my $binlog_line_1 = qr/at (\d+)$/m; my $binlog_line_2 = qr/^#(\d{6}\s+\d{1,2}:\d\d:\d\d)\s+server\s+id\s+(\d+)\s+end_log_pos\s+(\d+)\s+(?:CRC32\s+0x[a-f0-9]{8}\s+)?(\S+)\s*([^\n]*)$/m; my $binlog_line_2_rest = qr/thread_id=(\d+)\s+exec_time=(\d+)\s+error_code=(\d+)/m; sub new { my ( $class, %args ) = @_; my $self = { delim => undef, delim_len => 0, }; return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(next_event tell); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($next_event, $tell) = @args{@required_args}; local $INPUT_RECORD_SEPARATOR = ";\n#"; my $pos_in_log = $tell->(); my $stmt; my ($delim, $delim_len) = ($self->{delim}, $self->{delim_len}); EVENT: while ( defined($stmt = $next_event->()) ) { my @properties = ('pos_in_log', $pos_in_log); my ($ts, $sid, $end, $type, $rest); $pos_in_log = $tell->(); $stmt =~ s/;\n#?\Z//; my ( $got_offset, $got_hdr ); my $pos = 0; my $len = length($stmt); my $found_arg = 0; LINE: while ( $stmt =~ m/^(.*)$/mg ) { # /g requires scalar match. $pos = pos($stmt); # Be careful not to mess this up! my $line = $1; # Necessary for /g and pos() to work. $line =~ s/$delim// if $delim; PTDEBUG && _d($line); if ( $line =~ m/^\/\*.+\*\/;/ ) { PTDEBUG && _d('Comment line'); next LINE; } if ( $line =~ m/^DELIMITER/m ) { my ( $del ) = $line =~ m/^DELIMITER (\S*)$/m; if ( $del ) { $self->{delim_len} = $delim_len = length $del; $self->{delim} = $delim = quotemeta $del; PTDEBUG && _d('delimiter:', $delim); } else { PTDEBUG && _d('Delimiter reset to ;'); $self->{delim} = $delim = undef; $self->{delim_len} = $delim_len = 0; } next LINE; } next LINE if $line =~ m/End of log file/; if ( !$got_offset && (my ( $offset ) = $line =~ m/$binlog_line_1/m) ) { PTDEBUG && _d('Got the at offset line'); push @properties, 'offset', $offset; $got_offset++; } elsif ( !$got_hdr && $line =~ m/^#(\d{6}\s+\d{1,2}:\d\d:\d\d)/ ) { ($ts, $sid, $end, $type, $rest) = $line =~ m/$binlog_line_2/m; PTDEBUG && _d('Got the header line; type:', $type, 'rest:', $rest); push @properties, 'cmd', 'Query', 'ts', $ts, 'server_id', $sid, 'end_log_pos', $end; $got_hdr++; } elsif ( $line =~ m/^(?:#|use |SET)/i ) { if ( my ( $db ) = $line =~ m/^use ([^;]+)/ ) { PTDEBUG && _d("Got a default database:", $db); push @properties, 'db', $db; } elsif ( my ($setting) = $line =~ m/^SET\s+([^;]*)/ ) { PTDEBUG && _d("Got some setting:", $setting); push @properties, map { s/\s+//; lc } split(/,|\s*=\s*/, $setting); } } else { PTDEBUG && _d("Got the query/arg line at pos", $pos); $found_arg++; if ( $got_offset && $got_hdr ) { if ( $type eq 'Xid' ) { my ($xid) = $rest =~ m/(\d+)/; push @properties, 'Xid', $xid; } elsif ( $type eq 'Query' ) { my ($i, $t, $c) = $rest =~ m/$binlog_line_2_rest/m; push @properties, 'Thread_id', $i, 'Query_time', $t, 'error_code', $c; } elsif ( $type eq 'Start:' ) { PTDEBUG && _d("Binlog start"); } else { PTDEBUG && _d('Unknown event type:', $type); next EVENT; } } else { PTDEBUG && _d("It's not a query/arg, it's just some SQL fluff"); push @properties, 'cmd', 'Query', 'ts', undef; } my $delim_len = ($pos == length($stmt) ? $delim_len : 0); my $arg = substr($stmt, $pos - length($line) - $delim_len); $arg =~ s/$delim// if $delim; # Remove the delimiter. if ( $arg =~ m/^DELIMITER/m ) { my ( $del ) = $arg =~ m/^DELIMITER (\S*)$/m; if ( $del ) { $self->{delim_len} = $delim_len = length $del; $self->{delim} = $delim = quotemeta $del; PTDEBUG && _d('delimiter:', $delim); } else { PTDEBUG && _d('Delimiter reset to ;'); $del = ';'; $self->{delim} = $delim = undef; $self->{delim_len} = $delim_len = 0; } $arg =~ s/^DELIMITER.*$//m; # Remove DELIMITER from arg. } $arg =~ s/;$//gm; # Ensure ending ; are gone. $arg =~ s/\s+$//; # Remove trailing spaces and newlines. push @properties, 'arg', $arg, 'bytes', length($arg); last LINE; } } # LINE if ( $found_arg ) { PTDEBUG && _d('Properties of event:', Dumper(\@properties)); my $event = { @properties }; if ( $args{stats} ) { $args{stats}->{events_read}++; $args{stats}->{events_parsed}++; } return $event; } else { PTDEBUG && _d('Event had no arg'); } } # EVENT $args{oktorun}->(0) if $args{oktorun}; 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 BinaryLogParser package # ########################################################################### # ########################################################################### # GeneralLogParser 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/GeneralLogParser.pm # t/lib/GeneralLogParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package GeneralLogParser; 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 ) = @_; my $self = { pending => [], db_for => {}, }; return bless $self, $class; } my $genlog_line_1= qr{ \A (?:(\d{6}\s+\d{1,2}:\d\d:\d\d|\d{4}-\d{1,2}-\d{1,2}T\d\d:\d\d:\d\d\.\d+Z))? # Timestamp \s+ (?:\s*(\d+)) # Thread ID \s (\w+) # Command \s+ (.*) # Argument \Z }xs; sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(next_event tell); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($next_event, $tell) = @args{@required_args}; my $pending = $self->{pending}; my $db_for = $self->{db_for}; my $line; my $pos_in_log = $tell->(); LINE: while ( defined($line = shift @$pending) or defined($line = $next_event->()) ) { PTDEBUG && _d($line); my ($ts, $thread_id, $cmd, $arg) = $line =~ m/$genlog_line_1/; if ( !($thread_id && $cmd) ) { PTDEBUG && _d('Not start of general log event'); next; } my @properties = ('pos_in_log', $pos_in_log, 'ts', $ts, 'Thread_id', $thread_id); $pos_in_log = $tell->(); @$pending = (); if ( $cmd eq 'Query' ) { my $done = 0; do { $line = $next_event->(); if ( $line ) { my (undef, $next_thread_id, $next_cmd) = $line =~ m/$genlog_line_1/; if ( $next_thread_id && $next_cmd ) { PTDEBUG && _d('Event done'); $done = 1; push @$pending, $line; } else { PTDEBUG && _d('More arg:', $line); $arg .= $line; } } else { PTDEBUG && _d('No more lines'); $done = 1; } } until ( $done ); chomp $arg; push @properties, 'cmd', 'Query', 'arg', $arg; push @properties, 'bytes', length($properties[-1]); push @properties, 'db', $db_for->{$thread_id} if $db_for->{$thread_id}; } else { push @properties, 'cmd', 'Admin'; if ( $cmd eq 'Connect' ) { if ( $arg =~ m/^Access denied/ ) { $cmd = $arg; } else { my ($user) = $arg =~ m/(\S+)/; my ($db) = $arg =~ m/on (\S+)/; my $host; ($user, $host) = split(/@/, $user); PTDEBUG && _d('Connect', $user, '@', $host, 'on', $db); push @properties, 'user', $user if $user; push @properties, 'host', $host if $host; push @properties, 'db', $db if $db; $db_for->{$thread_id} = $db; } } elsif ( $cmd eq 'Init' ) { $cmd = 'Init DB'; $arg =~ s/^DB\s+//; my ($db) = $arg =~ /(\S+)/; PTDEBUG && _d('Init DB:', $db); push @properties, 'db', $db if $db; $db_for->{$thread_id} = $db; } push @properties, 'arg', "administrator command: $cmd"; push @properties, 'bytes', length($properties[-1]); } push @properties, 'Query_time', 0; PTDEBUG && _d('Properties of event:', Dumper(\@properties)); my $event = { @properties }; if ( $args{stats} ) { $args{stats}->{events_read}++; $args{stats}->{events_parsed}++; } return $event; } # LINE @{$self->{pending}} = (); $args{oktorun}->(0) if $args{oktorun}; 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 GeneralLogParser package # ########################################################################### # ########################################################################### # RawLogParser 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/RawLogParser.pm # t/lib/RawLogParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package RawLogParser; 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 ) = @_; my $self = { }; return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(next_event tell); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($next_event, $tell) = @args{@required_args}; my $line; my $pos_in_log = $tell->(); LINE: while ( defined($line = $next_event->()) ) { PTDEBUG && _d($line); chomp($line); my @properties = ( 'pos_in_log', $pos_in_log, 'cmd', 'Query', 'bytes', length($line), 'Query_time', 0, 'arg', $line, ); $pos_in_log = $tell->(); PTDEBUG && _d('Properties of event:', Dumper(\@properties)); my $event = { @properties }; if ( $args{stats} ) { $args{stats}->{events_read}++; $args{stats}->{events_parsed}++; } return $event; } $args{oktorun}->(0) if $args{oktorun}; 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 RawLogParser package # ########################################################################### # ########################################################################### # ProtocolParser 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/ProtocolParser.pm # t/lib/ProtocolParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package ProtocolParser; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; use File::Basename qw(basename); use File::Temp qw(tempfile); eval { require IO::Uncompress::Inflate; # yum: perl-IO-Compress-Zlib IO::Uncompress::Inflate->import(qw(inflate $InflateError)); }; use Data::Dumper; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; sub new { my ( $class, %args ) = @_; my $self = { server => $args{server}, port => $args{port}, sessions => {}, o => $args{o}, }; return bless $self, $class; } sub parse_event { my ( $self, %args ) = @_; my @required_args = qw(event); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my $packet = @args{@required_args}; if ( $self->{buffer} ) { my ($packet_from, $session) = $self->_get_session($packet); if ( $packet->{data_len} ) { if ( $packet_from eq 'client' ) { push @{$session->{client_packets}}, $packet; PTDEBUG && _d('Saved client packet'); } else { push @{$session->{server_packets}}, $packet; PTDEBUG && _d('Saved server packet'); } } return unless ($packet_from eq 'client') && ($packet->{fin} || $packet->{rst}); my $event; map { $event = $self->_parse_packet($_, $args{misc}); $args{stats}->{events_parsed}++ if $args{stats}; } sort { $a->{seq} <=> $b->{seq} } @{$session->{client_packets}}; map { $event = $self->_parse_packet($_, $args{misc}); $args{stats}->{events_parsed}++ if $args{stats}; } sort { $a->{seq} <=> $b->{seq} } @{$session->{server_packets}}; return $event; } if ( $packet->{data_len} == 0 ) { PTDEBUG && _d('No TCP data'); return; } my $event = $self->_parse_packet($packet, $args{misc}); $args{stats}->{events_parsed}++ if $args{stats}; return $event; } sub _parse_packet { my ( $self, $packet, $misc ) = @_; my ($packet_from, $session) = $self->_get_session($packet); PTDEBUG && _d('State:', $session->{state}); push @{$session->{raw_packets}}, $packet->{raw_packet} unless $misc->{recurse}; if ( $session->{buff} ) { $session->{buff_left} -= $packet->{data_len}; if ( $session->{buff_left} > 0 ) { PTDEBUG && _d('Added data to buff; expecting', $session->{buff_left}, 'more bytes'); return; } PTDEBUG && _d('Got all data; buff left:', $session->{buff_left}); $packet->{data} = $session->{buff} . $packet->{data}; $packet->{data_len} += length $session->{buff}; $session->{buff} = ''; $session->{buff_left} = 0; } $packet->{data} = pack('H*', $packet->{data}) unless $misc->{recurse}; my $event; if ( $packet_from eq 'server' ) { $event = $self->_packet_from_server($packet, $session, $misc); } elsif ( $packet_from eq 'client' ) { $event = $self->_packet_from_client($packet, $session, $misc); } else { die 'Packet origin unknown'; } PTDEBUG && _d('State:', $session->{state}); if ( $session->{out_of_order} ) { PTDEBUG && _d('Session packets are out of order'); push @{$session->{packets}}, $packet; $session->{ts_min} = $packet->{ts} if $packet->{ts} lt ($session->{ts_min} || ''); $session->{ts_max} = $packet->{ts} if $packet->{ts} gt ($session->{ts_max} || ''); if ( $session->{have_all_packets} ) { PTDEBUG && _d('Have all packets; ordering and processing'); delete $session->{out_of_order}; delete $session->{have_all_packets}; map { $event = $self->_parse_packet($_, { recurse => 1 }); } sort { $a->{seq} <=> $b->{seq} } @{$session->{packets}}; } } PTDEBUG && _d('Done with packet; event:', Dumper($event)); return $event; } sub _get_session { my ( $self, $packet ) = @_; my $src_host = "$packet->{src_host}:$packet->{src_port}"; my $dst_host = "$packet->{dst_host}:$packet->{dst_port}"; if ( my $server = $self->{server} ) { # Watch only the given server. $server .= ":$self->{port}"; if ( $src_host ne $server && $dst_host ne $server ) { PTDEBUG && _d('Packet is not to or from', $server); return; } } my $packet_from; my $client; if ( $src_host =~ m/:$self->{port}$/ ) { $packet_from = 'server'; $client = $dst_host; } elsif ( $dst_host =~ m/:$self->{port}$/ ) { $packet_from = 'client'; $client = $src_host; } else { warn 'Packet is not to or from server: ', Dumper($packet); return; } PTDEBUG && _d('Client:', $client); if ( !exists $self->{sessions}->{$client} ) { PTDEBUG && _d('New session'); $self->{sessions}->{$client} = { client => $client, state => undef, raw_packets => [], }; }; my $session = $self->{sessions}->{$client}; return $packet_from, $session; } sub _packet_from_server { die "Don't call parent class _packet_from_server()"; } sub _packet_from_client { die "Don't call parent class _packet_from_client()"; } sub make_event { my ( $self, $session, $packet ) = @_; die "Event has no attributes" unless scalar keys %{$session->{attribs}}; die "Query has no arg attribute" unless $session->{attribs}->{arg}; my $start_request = $session->{start_request} || 0; my $start_reply = $session->{start_reply} || 0; my $end_reply = $session->{end_reply} || 0; PTDEBUG && _d('Request start:', $start_request, 'reply start:', $start_reply, 'reply end:', $end_reply); my $event = { Query_time => $self->timestamp_diff($start_request, $start_reply), Transmit_time => $self->timestamp_diff($start_reply, $end_reply), }; @{$event}{keys %{$session->{attribs}}} = values %{$session->{attribs}}; return $event; } sub _get_errors_fh { my ( $self ) = @_; return $self->{errors_fh} if $self->{errors_fh}; my $exec = basename($0); my ($errors_fh, $filename); if ( $filename = $ENV{PERCONA_TOOLKIT_TCP_ERRORS_FILE} ) { open $errors_fh, ">", $filename or die "Cannot open $filename for writing (supplied from " . "PERCONA_TOOLKIT_TCP_ERRORS_FILE): $OS_ERROR"; } else { ($errors_fh, $filename) = tempfile("/tmp/$exec-errors.XXXXXXX", UNLINK => 0); } $self->{errors_file} = $filename; $self->{errors_fh} = $errors_fh; return $errors_fh; } sub fail_session { my ( $self, $session, $reason ) = @_; PTDEBUG && _d('Failed session', $session->{client}, 'because', $reason); delete $self->{sessions}->{$session->{client}}; return if $self->{_no_save_error}; my $errors_fh = $self->_get_errors_fh(); warn "TCP session $session->{client} had errors, will save them in $self->{errors_file}\n" unless $self->{_warned_for}->{$self->{errors_file}}++; my $raw_packets = delete $session->{raw_packets}; $session->{reason_for_failure} = $reason; my $session_dump = '# ' . Dumper($session); chomp $session_dump; $session_dump =~ s/\n/\n# /g; print $errors_fh join("\n", $session_dump, @$raw_packets), "\n"; return; } sub timestamp_diff { my ( $self, $start, $end ) = @_; return 0 unless $start && $end; my $sd = substr($start, 0, 11, ''); my $ed = substr($end, 0, 11, ''); my ( $sh, $sm, $ss ) = split(/:/, $start); my ( $eh, $em, $es ) = split(/:/, $end); my $esecs = ($eh * 3600 + $em * 60 + $es); my $ssecs = ($sh * 3600 + $sm * 60 + $ss); if ( $sd eq $ed ) { return sprintf '%.6f', $esecs - $ssecs; } else { # Assume only one day boundary has been crossed, no DST, etc return sprintf '%.6f', ( 86_400 - $ssecs ) + $esecs; } } sub uncompress_data { my ( $self, $data, $len ) = @_; die "I need data" unless $data; die "I need a len argument" unless $len; die "I need a scalar reference to data" unless ref $data eq 'SCALAR'; PTDEBUG && _d('Uncompressing data'); our $InflateError; my $comp_bin_data = pack('H*', $$data); my $uncomp_bin_data = ''; my $z = new IO::Uncompress::Inflate( \$comp_bin_data ) or die "IO::Uncompress::Inflate failed: $InflateError"; my $status = $z->read(\$uncomp_bin_data, $len) or die "IO::Uncompress::Inflate failed: $InflateError"; my $uncomp_data = unpack('H*', $uncomp_bin_data); return \$uncomp_data; } 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 ProtocolParser 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$|cluster$|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}; my $o = $self->{OptionParser}; $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)); my $slave_dsn = $dsn; if ($o->got('slave-user')) { $slave_dsn->{u} = $o->get('slave-user'); PTDEBUG && _d("Using slave user ".$o->get('slave-user')." on ".$slave_dsn->{h}.":".$slave_dsn->{P}); } if ($o->got('slave-password')) { $slave_dsn->{p} = $o->get('slave-password'); PTDEBUG && _d("Slave password set"); } push @$slaves, $make_cxn->(dsn => $slave_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 FULL 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 # ########################################################################### # ########################################################################### # 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) = @_; printf STDERR "$name: %3d%% %s remain\n", $fraction * 100, Transformers::secs_to_time($remaining); }, %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 # ########################################################################### # ########################################################################### # FileIterator 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/FileIterator.pm # t/lib/FileIterator.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package FileIterator; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; sub new { my ( $class, %args ) = @_; my $self = { %args, }; return bless $self, $class; } sub get_file_itr { my ( $self, @filenames ) = @_; my @final_filenames; FILENAME: foreach my $fn ( @filenames ) { if ( !defined $fn ) { warn "Skipping undefined filename"; next FILENAME; } if ( $fn ne '-' ) { if ( !-e $fn || !-r $fn ) { warn "$fn does not exist or is not readable"; next FILENAME; } } push @final_filenames, $fn; } if ( !@filenames ) { push @final_filenames, '-'; PTDEBUG && _d('Auto-adding "-" to the list of filenames'); } PTDEBUG && _d('Final filenames:', @final_filenames); return sub { while ( @final_filenames ) { my $fn = shift @final_filenames; PTDEBUG && _d('Filename:', $fn); if ( $fn eq '-' ) { # Magical STDIN filename. return (*STDIN, undef, undef); } open my $fh, '<', $fn or warn "Cannot open $fn: $OS_ERROR"; if ( $fh ) { return ( $fh, $fn, -s $fn ); } } return (); # Avoids $f being set to 0 in list context. }; } 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 FileIterator package # ########################################################################### # ########################################################################### # Runtime 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/Runtime.pm # t/lib/Runtime.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package Runtime; 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(now); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless exists $args{$arg}; } my $run_time = $args{run_time}; if ( defined $run_time ) { die "run_time must be > 0" if $run_time <= 0; } my $now = $args{now}; die "now must be a callback" unless ref $now eq 'CODE'; my $self = { run_time => $run_time, now => $now, start_time => undef, end_time => undef, time_left => undef, stop => 0, }; return bless $self, $class; } sub time_left { my ( $self, %args ) = @_; if ( $self->{stop} ) { PTDEBUG && _d("No time left because stop was called"); return 0; } my $now = $self->{now}->(%args); PTDEBUG && _d("Current time:", $now); if ( !defined $self->{start_time} ) { $self->{start_time} = $now; } return unless defined $now; my $run_time = $self->{run_time}; return unless defined $run_time; if ( !$self->{end_time} ) { $self->{end_time} = $now + $run_time; PTDEBUG && _d("End time:", $self->{end_time}); } $self->{time_left} = $self->{end_time} - $now; PTDEBUG && _d("Time left:", $self->{time_left}); return $self->{time_left}; } sub have_time { my ( $self, %args ) = @_; my $time_left = $self->time_left(%args); return 1 if !defined $time_left; # run forever return $time_left <= 0 ? 0 : 1; # <=0s means run time has elapsed } sub time_elapsed { my ( $self, %args ) = @_; my $start_time = $self->{start_time}; return 0 unless $start_time; my $now = $self->{now}->(%args); PTDEBUG && _d("Current time:", $now); my $time_elapsed = $now - $start_time; PTDEBUG && _d("Time elapsed:", $time_elapsed); if ( $time_elapsed < 0 ) { warn "Current time $now is earlier than start time $start_time"; } return $time_elapsed; } sub reset { my ( $self ) = @_; $self->{start_time} = undef; $self->{end_time} = undef; $self->{time_left} = undef; $self->{stop} = 0; PTDEBUG && _d("Reset run time"); return; } sub stop { my ( $self ) = @_; $self->{stop} = 1; return; } sub start { my ( $self ) = @_; $self->{stop} = 0; 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 Runtime package # ########################################################################### # ########################################################################### # Pipeline 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/Pipeline.pm # t/lib/Pipeline.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package Pipeline; 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; use Time::HiRes qw(time); sub new { my ( $class, %args ) = @_; my @required_args = qw(); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless defined $args{$arg}; } my $self = { instrument => PTDEBUG, continue_on_error => 0, %args, procs => [], # coderefs for pipeline processes names => [], # names for each ^ pipeline proc instrumentation => { # keyed on proc index in procs Pipeline => { time => 0, calls => 0, }, }, }; return bless $self, $class; } sub add { my ( $self, %args ) = @_; my @required_args = qw(process name); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless defined $args{$arg}; } my ($process, $name) = @args{@required_args}; push @{$self->{procs}}, $process; push @{$self->{names}}, $name; $self->{retries}->{$name} = $args{retry_on_error} || 100; if ( $self->{instrument} ) { $self->{instrumentation}->{$name} = { time => 0, calls => 0 }; } PTDEBUG && _d("Added pipeline process", $name); return; } sub processes { my ( $self ) = @_; return @{$self->{names}}; } sub execute { my ( $self, %args ) = @_; die "Cannot execute pipeline because no process have been added" unless scalar @{$self->{procs}}; my $oktorun = $args{oktorun}; die "I need an oktorun argument" unless $oktorun; die '$oktorun argument must be a reference' unless ref $oktorun; my $pipeline_data = $args{pipeline_data} || {}; $pipeline_data->{oktorun} = $oktorun; my $stats = $args{stats}; # optional PTDEBUG && _d("Pipeline starting at", time); my $instrument = $self->{instrument}; my $processes = $self->{procs}; EVENT: while ( $$oktorun ) { my $procno = 0; # so we can see which proc if one causes an error my $output; eval { PIPELINE_PROCESS: while ( $procno < scalar @{$self->{procs}} ) { my $call_start = $instrument ? time : 0; PTDEBUG && _d("Pipeline process", $self->{names}->[$procno]); $output = $processes->[$procno]->($pipeline_data); if ( $instrument ) { my $call_end = time; my $call_t = $call_end - $call_start; $self->{instrumentation}->{$self->{names}->[$procno]}->{time} += $call_t; $self->{instrumentation}->{$self->{names}->[$procno]}->{count}++; $self->{instrumentation}->{Pipeline}->{time} += $call_t; $self->{instrumentation}->{Pipeline}->{count}++; } if ( !$output ) { PTDEBUG && _d("Pipeline restarting early after", $self->{names}->[$procno]); if ( $stats ) { $stats->{"pipeline_restarted_after_" .$self->{names}->[$procno]}++; } last PIPELINE_PROCESS; } $procno++; } }; if ( $EVAL_ERROR ) { my $name = $self->{names}->[$procno] || ""; my $msg = "Pipeline process " . ($procno + 1) . " ($name) caused an error: " . $EVAL_ERROR; if ( !$self->{continue_on_error} ) { die $msg . "Terminating pipeline because --continue-on-error " . "is false.\n"; } elsif ( defined $self->{retries}->{$name} ) { my $n = $self->{retries}->{$name}; if ( $n ) { warn $msg . "Will retry pipeline process $procno ($name) " . "$n more " . ($n > 1 ? "times" : "time") . ".\n"; $self->{retries}->{$name}--; } else { die $msg . "Terminating pipeline because process $procno " . "($name) caused too many errors.\n"; } } else { warn $msg; } } } PTDEBUG && _d("Pipeline stopped at", time); return; } sub instrumentation { my ( $self ) = @_; return $self->{instrumentation}; } sub reset { my ( $self ) = @_; foreach my $proc_name ( @{$self->{names}} ) { if ( exists $self->{instrumentation}->{$proc_name} ) { $self->{instrumentation}->{$proc_name}->{calls} = 0; $self->{instrumentation}->{$proc_name}->{time} = 0; } } $self->{instrumentation}->{Pipeline}->{calls} = 0; $self->{instrumentation}->{Pipeline}->{time} = 0; 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 Pipeline 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_query_digest; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; use Time::Local qw(timelocal); use Time::HiRes qw(time usleep); use List::Util qw(max); use Scalar::Util qw(looks_like_number); use POSIX qw(signal_h); use Data::Dumper; use Percona::Toolkit; $Data::Dumper::Indent = 1; $Data::Dumper::Sortkeys = 1; $Data::Dumper::Quotekeys = 0; $OUTPUT_AUTOFLUSH = 1; Transformers->import(qw( shorten micro_t percentage_of ts make_checksum any_unix_timestamp parse_timestamp unix_timestamp crc32 )); use sigtrap 'handler', \&sig_int, 'normal-signals'; # Global variables. Only really essential variables should be here. my $oktorun = 1; my $ep_dbh; # For --explain my $ps_dbh; # For Processlist my $aux_dbh; # For --aux-dsn (--since/--until "MySQL expression") my $resume_file; my $resume = {}; my $offset; my $exit_status = 0; (my $tool = __PACKAGE__) =~ tr/_/-/; sub main { # Reset global vars, else tests will fail. local @ARGV = @_; $oktorun = 1; $resume = {}; $offset = undef; $exit_status = 0; # ########################################################################## # Get configuration information. # ########################################################################## my $o = new OptionParser(); $o->get_specs(); $o->get_opts(); my $dp = $o->DSNParser(); $dp->prop('set-vars', $o->set_vars()); my $aux_dsn; for my $i (0..$#ARGV) { next if -e $ARGV[$i]; $aux_dsn = $dp->parse(splice(@ARGV, $i, 1)); last; } # Frequently used options. my $review_dsn = handle_special_defaults($o, 'review'); my $history_dsn = handle_special_defaults($o, 'history'); my @groupby = @{$o->get('group-by')}; my @orderby; if ( (grep { $_ =~ m/genlog|GeneralLogParser|rawlog|RawLogParser/ } @{$o->get('type')}) && !$o->got('order-by') ) { @orderby = 'Query_time:cnt'; } else { @orderby = @{$o->get('order-by')}; } if ( !$o->get('help') ) { if ( $o->get('outliers') && grep { $_ !~ m/^\w+:[0-9.]+(?::[0-9.]+)?$/ } @{$o->get('outliers')} ) { $o->save_error('--outliers requires two or three colon-separated fields'); } if ( $o->get('progress') ) { eval { Progress->validate_spec($o->get('progress')) }; if ( $EVAL_ERROR ) { chomp $EVAL_ERROR; $o->save_error("--progress $EVAL_ERROR"); } } if ( my $patterns = $o->get('embedded-attributes') ) { $o->save_error("--embedded-attributes should be passed two " . "comma-separated patterns, got " . scalar(@$patterns) ) unless scalar(@$patterns) == 2; for my $re (@$patterns) { no re 'eval'; eval { qr/$re/ }; if ( $EVAL_ERROR ) { $o->save_error("--embedded-attributes $EVAL_ERROR") } } } } # Set an orderby for each groupby; use the default orderby if there # are more groupby than orderby attribs. my $default_orderby = $o->get_defaults()->{'order-by'}; foreach my $i ( 0..$#groupby ) { $orderby[$i] ||= $default_orderby; } $o->set('order-by', \@orderby); my $run_time_mode = lc $o->get('run-time-mode'); my $run_time_interval; eval { $run_time_interval = verify_run_time( run_mode => $run_time_mode, run_time => $o->get('run-time'), ); }; if ( $EVAL_ERROR ) { chomp $EVAL_ERROR; $o->save_error($EVAL_ERROR); } $o->usage_or_errors(); # ######################################################################## # Common modules. # ####################################################################### my $q = new Quoter(); my $qp = new QueryParser(); my $qr = new QueryRewriter(QueryParser=>$qp, match_embedded_numbers => $o->get('preserve-embedded-numbers') ? 1 : 0); my %common_modules = ( OptionParser => $o, DSNParser => $dp, Quoter => $q, QueryParser => $qp, QueryRewriter => $qr, ); # ######################################################################## # Set up for --explain # ######################################################################## if ( my $ep_dsn = $o->get('explain') ) { $ep_dbh = get_cxn( for => '--explain', dsn => $ep_dsn, OptionParser => $o, DSNParser => $dp, opts => { AutoCommit => 1 }, ); $ep_dbh->{InactiveDestroy} = 1; # Don't die on fork(). } # ######################################################################## # Set up for --review. # ######################################################################## my $qv; # QueryReview my $qv_dbh; # For QueryReview my $tp = new TableParser(Quoter => $q); if ( $review_dsn ) { my %dsn_without_Dt = %$review_dsn; delete $dsn_without_Dt{D}; delete $dsn_without_Dt{t}; $qv_dbh = get_cxn( for => '--review', dsn => \%dsn_without_Dt, OptionParser => $o, DSNParser => $dp, opts => { AutoCommit => 1 }, ); $qv_dbh->{InactiveDestroy} = 1; # Don't die on fork(). my @db_tbl = @{$review_dsn}{qw(D t)}; my $db_tbl = $q->quote(@db_tbl); my $create_review_sql = $o->read_para_after( __FILE__, qr/\bMAGIC_create_review_table\b/); $create_review_sql =~ s/\bquery_review\b/$db_tbl/; create_review_tables( type => 'review', dbh => $qv_dbh, full_table => $db_tbl, create_table_sql => $create_review_sql, create_table => $o->get('create-review-table'), TableParser => $tp, ); # Set up the new QueryReview object. my $struct = $tp->parse($tp->get_create_table($qv_dbh, @db_tbl)); $qv = new QueryReview( dbh => $qv_dbh, db_tbl => $db_tbl, tbl_struct => $struct, quoter => $q, ); } # ######################################################################## # Set up for --history. # ######################################################################## my $qh; # QueryHistory my $qh_dbh; if ( $history_dsn ) { my %dsn_without_Dt = %$history_dsn; delete $dsn_without_Dt{D}; delete $dsn_without_Dt{t}; my $qh_dbh = get_cxn( for => '--history', dsn => \%dsn_without_Dt, OptionParser => $o, DSNParser => $dp, opts => { AutoCommit => 1 }, ); $qh_dbh->{InactiveDestroy} = 1; # Don't die on fork(). my @hdb_tbl = @{$history_dsn}{qw(D t)}; my $hdb_tbl = $q->quote(@hdb_tbl); my $create_history_sql = $o->read_para_after( __FILE__, qr/\bMAGIC_create_history_table\b/); $create_history_sql =~ s/\bquery_history\b/$hdb_tbl/; create_review_tables( type => 'history', dbh => $qh_dbh, full_table => $hdb_tbl, create_table_sql => $create_history_sql, create_table => $o->get('create-history-table'), TableParser => $tp, ); my $tbl = $tp->parse($tp->get_create_table($qh_dbh, @hdb_tbl)); my $pat = $o->read_para_after(__FILE__, qr/\bMAGIC_history_columns\b/); $pat =~ s/\s+//g; $pat = qr/^(.*?)_($pat)$/; $qh = QueryHistory->new( history_dbh => $qh_dbh, column_pattern => $pat, ); # And tell the QueryReview that it has more work to do. $qh->set_history_options( table => $hdb_tbl, tbl_struct => $tbl, ); } # ######################################################################## # Create all the pipeline processes that do all the work: get input, # parse events, manage runtime, switch iterations, aggregate, etc. # ######################################################################## # These four vars are passed to print_reports(). my @ea; # EventAggregator objs my @tl; # EventTimeline obj my @read_files; # file names that have been parsed my %stats; # various stats/counters used in some procs # The pipeline data hashref is passed to each proc. Procs use this to # pass data through the pipeline. The most importat data is the event. # Other data includes in the next_event callback, time and iters left, # etc. This hashref is accessed inside a proc via the $args arg. my $pipeline_data = { iter => 1, stats => \%stats, }; my $pipeline = new Pipeline( continue_on_error => $o->get('continue-on-error'), ); # ######################################################################## # Procs before the terminator are, in general, responsible for getting # and event that procs after the terminator process before aggregation # at the end of the pipeline. Therefore, these pre-terminator procs # should not assume an event exists. If one does, they should let the # pipeline continue. Only the terminator proc terminates the pipeline. # ######################################################################## { # prep $pipeline->add( name => 'prep', process => sub { my ( $args ) = @_; # Stuff you'd like to do to make sure pipeline data is prepped # and ready to go... $args->{event} = undef; # remove event from previous pass return $args; }, ); } # prep { # input my $fi = FileIterator->new(); my $next_file = $fi->get_file_itr(@ARGV); my $input_fh; # the current input fh my $pr; # Progress obj for ^ $pipeline->add( name => 'input', process => sub { my ( $args ) = @_; # Only get the next file when there's no fh or no more events in # the current fh. This allows us to do collect-and-report cycles # (i.e. iterations) on huge files. This doesn't apply to infinite # inputs because they don't set more_events false. if ( !$args->{input_fh} || !$args->{more_events} ) { # Close the current file. if ( $args->{input_fh} ) { close $args->{input_fh} or die "Cannot close input fh: $OS_ERROR"; } # Open the next file. my ($fh, $filename, $filesize) = $next_file->(); if ( $fh ) { my $fileno = fileno $fh; if ($fileno == 0) { print "Reading from STDIN ...\n"; } PTDEBUG && _d('Reading', $filename); PTDEBUG && _d('File size:', $filesize); # catch if user is trying to use an uncoverted (raw) binlog # issue 1377888 if ( $filename && $o->get('type')->[0] eq 'binlog') { if (is_raw_binlog($filename)) { warn "Binlog file $filename must first be converted to text format using mysqlbinlog"; return 1; } } push @read_files, { name => ($filename || "STDIN"), size => $filesize }; # Read the file offset for --resume. if ( ($resume_file = $o->get('resume')) && $filename ) { if ( -s $resume_file ) { open my $resume_fh, "<", $resume_file or die "Cannot open $resume_file: $OS_ERROR"; my $resume_offset = do { local $/; <$resume_fh> }; close $resume_fh or die "Error close $resume_file: $OS_ERROR"; chomp($resume_offset) if $resume_offset; if ( looks_like_number($resume_offset) ) { PTDEBUG && _d('Resuming at offset', $resume_offset); $resume->{simple} = 1; seek $fh, $resume_offset, 0 or die "Error seeking to $resume_offset in " . "$resume_file: $OS_ERROR"; warn "# Resuming $filename from offset " . "$resume_offset (file size: $filesize)...\n"; } else { $resume->{simple} = 0; # enhanced resume file map { my $line = $_; chomp $line; my ($key, $value) = split('=', $line); if ( !$key || !defined $value || !looks_like_number($value) || $value < 0 ) { $exit_status = 1; warn "Invalid line in --resume $resume_file: $line\n"; $oktorun = 0; return; } $resume->{$key} = $value; } split("\n", $resume_offset); if ( $resume->{end_offset} && $resume->{end_offset} <= ($resume->{stop_offset} || 0) ) { close $args->{input_fh} if $args->{input_fh}; $args->{input_fh} = undef; $args->{more_events} = 0; $oktorun = 0; $resume_file = ''; warn "# Not resuming $filename because " . "end_offset $resume->{end_offset} is " . "less than or equal to stop_offset " . ($resume->{stop_offset} || 0) . "\n"; } else { $resume_offset = $resume->{stop_offset} || $resume->{start_offset} || 0; seek $fh, $resume_offset, 0 or die "Error seeking to $resume_offset in " . "$resume_file: $OS_ERROR"; warn "# Resuming $filename from offset " . "$resume_offset to " . ($resume->{end_offset} ? $resume->{end_offset} : "end of file") . " (file size: $filesize)...\n"; } } } else { warn "# Resuming $filename from offset 0 because " . "resume file $filename does not exist " . "(file size: $filesize)...\n"; $resume->{simple} = 0; $resume->{start_offset} = 0; } } # Create callback to read next event. Some inputs, like # Processlist, may use something else but most next_event. if ( my $read_time = $o->get('read-timeout') ) { $args->{next_event} = sub { return read_timeout($fh, $read_time); }; } else { $args->{next_event} = sub { return <$fh>; }; } $args->{filename} = $filename; $args->{input_fh} = $fh; $args->{tell} = sub { $offset = tell $fh; # update global $offset if ( $args->{filename} ) { $args->{pos_for}->{$args->{filename}} = $offset; } return $offset; # legacy: return global $offset }; $args->{more_events} = 1; # Reset in case we read two logs out of order by time. $args->{past_since} = 0 if $o->get('since'); $args->{at_until} = 0 if $o->get('until'); # Make a progress reporter, one per file. if ( $o->get('progress') && $filename && -e $filename ) { $pr = new Progress( jobsize => $filesize, spec => $o->get('progress'), name => $filename, ); } } else { PTDEBUG && _d("No more input"); # This will cause terminator proc to terminate the pipeline. $args->{input_fh} = undef; $args->{more_events} = 0; } } elsif ( $resume->{end_offset} && $offset >= $resume->{end_offset} ) { PTDEBUG && _d('Offset', $offset, 'at end_offset', $resume->{end_offset}); close $args->{input_fh} if $args->{input_fh}; $args->{input_fh} = undef; $args->{more_events} = 0; } else { $pr->update($args->{tell}) if $pr; } return $args; }, ); } # input my $ps_dsn; my @parsers; { # event my $misc; if ( $ps_dsn = $o->get('processlist') ) { my $ms = new MasterSlave( OptionParser => $o, DSNParser => $dp, Quoter => $q, ); my $pl = new Processlist( interval => $o->get('interval') * 1_000_000, MasterSlave => $ms ); my ( $sth, $cxn ); my $cur_server = 'processlist'; my $cur_time = 0; if ( $o->get('ask-pass') ) { $ps_dsn->{p} = OptionParser::prompt_noecho("Enter password for " . "--processlist: "); $o->get('processlist', $ps_dsn); } my $code = sub { my $err; do { eval { $sth->execute; }; $err = $EVAL_ERROR; if ( $err ) { # Try to reconnect when there's an error. eval { if ( !$ps_dbh || !$ps_dbh->ping ) { PTDEBUG && _d('Getting a dbh from', $cur_server); $ps_dbh = $dp->get_dbh( $dp->get_cxn_params($o->get($cur_server)), {AutoCommit => 1}); $ps_dbh->{InactiveDestroy} = 1; # Don't die on fork(). } $cur_time = time(); $sth = $ps_dbh->prepare('SHOW FULL PROCESSLIST'); $cxn = $ps_dbh->{mysql_thread_id}; $sth->execute(); }; $err = $EVAL_ERROR; if ( $err ) { warn $err; sleep 1; } } } until ( $sth && !$err ); return [ grep { $_->[0] != $cxn } @{ $sth->fetchall_arrayref(); } ]; }; $pipeline->add( name => ref $pl, process => sub { my ( $args ) = @_; my $event = $pl->parse_event(code => $code); if ( $event ) { sanitize_event($event); $args->{event} = $event; } return $args; }, ); } # get events from processlist else { my %alias_for = ( slowlog => ['SlowLogParser'], binlog => ['BinaryLogParser'], genlog => ['GeneralLogParser'], tcpdump => ['TcpdumpParser','MySQLProtocolParser'], rawlog => ['RawLogParser'], ); my $type = $o->get('type'); $type = $alias_for{$type->[0]} if $alias_for{$type->[0]}; my ($server, $port); if ( my $watch_server = $o->get('watch-server') ) { # This should match all combinations of HOST and PORT except # "host-name.port" because "host.mysql" could be either # host "host" and port "mysql" or just host "host.mysql" # (e.g. if someone added "127.1 host.mysql" to etc/hosts). # So host-name* requires a colon between it and a port. ($server, $port) = $watch_server =~ m/^((?:\d+\.\d+\.\d+\.\d+|[\w\.\-]+\w))(?:[\:\.](\S+))?/; PTDEBUG && _d('Watch server', $server, 'port', $port); } foreach my $module ( @$type ) { my $parser; eval { $parser = $module->new( server => $server, port => $port, o => $o, ); }; if ( $EVAL_ERROR ) { if ( $EVAL_ERROR =~ m/perhaps you forgot to load/ ) { # There is no module to handle --type, so wrong --type die "'$module' is not a valid input type. " . "Please check the documentation for --type.\n"; } die "Failed to load $module module: $EVAL_ERROR"; } push @parsers, $parser; $pipeline->add( name => ref $parser, process => sub { my ( $args ) = @_; if ( $args->{input_fh} ) { my $event = $parser->parse_event( event => $args->{event}, next_event => $args->{next_event}, tell => $args->{tell}, misc => $args->{misc}, oktorun => sub { $args->{more_events} = $_[0]; }, stats => $args->{stats}, ); if ( $event ) { sanitize_event($event); $args->{event} = $event; return $args; } PTDEBUG && _d("No more events, input EOF"); return; # next input } # No input, let pipeline run so the last report is printed. return $args; }, ); } } # get events from log file if ( my $patterns = $o->get('embedded-attributes') ) { $misc->{embed} = qr/$patterns->[0]/; $misc->{capture} = qr/$patterns->[1]/; PTDEBUG && _d('Patterns for embedded attributes:', $misc->{embed}, $misc->{capture}); } $pipeline_data->{misc} = $misc; } # event { # runtime my $now_callback; if ( $run_time_mode eq 'clock' ) { $now_callback = sub { return time; }; } elsif ( $run_time_mode eq 'event' ) { $now_callback = sub { my ( %args ) = @_; my $event = $args{event}; return unless $event && $event->{ts}; PTDEBUG && _d("Log time:", $event->{ts}); return unix_timestamp(parse_timestamp($event->{ts})); }; } else { $now_callback = sub { return; }; } $pipeline_data->{Runtime} = new Runtime( now => $now_callback, run_time => $o->get('run-time'), ); $pipeline->add( name => 'runtime', process => sub { my ( $args ) = @_; if ( $run_time_mode eq 'interval' ) { my $event = $args->{event}; return $args unless $event && $event->{ts}; my $ts = $args->{unix_ts} = unix_timestamp(parse_timestamp($event->{ts})); if ( !$args->{next_ts_interval} ) { # We need to figure out what interval we're in and what # interval is next. So first we need to parse the ts. if ( my($y, $m, $d, $h, $i, $s) = $args->{event}->{ts} =~ m/^$Transformers::mysql_ts$/ ) { my $rt = $o->get('run-time'); if ( $run_time_interval == 60 ) { PTDEBUG && _d("Run-time interval in seconds"); my $this_minute = unix_timestamp(parse_timestamp( "$y$m$d $h:$i:00")); do { $this_minute += $rt } until $this_minute > $ts; $args->{next_ts_interval} = $this_minute; } elsif ( $run_time_interval == 3600 ) { PTDEBUG && _d("Run-time interval in minutes"); my $this_hour = unix_timestamp(parse_timestamp( "$y$m$d $h:00:00")); do { $this_hour += $rt } until $this_hour > $ts; $args->{next_ts_interval} = $this_hour; } elsif ( $run_time_interval == 86400 ) { PTDEBUG && _d("Run-time interval in days"); my $this_day = unix_timestamp(parse_timestamp( "$y$m$d 00:00:00")); $args->{next_ts_interval} = $this_day + $rt; } else { die "Invalid run-time interval: $run_time_interval"; } PTDEBUG && _d("First ts interval:", $args->{next_ts_interval}); } else { PTDEBUG && _d("Failed to parse MySQL ts:", $args->{event}->{ts}); } } } else { # Clock and event run-time modes need to check the time. $args->{time_left} = $args->{Runtime}->time_left(event=>$args->{event}); } return $args; }, ); } # runtime # Filter early for --since and --until. # If --since or --until is a MySQL expression, then any_unix_timestamp() # will need this callback to execute the expression. We don't know what # type of time value the user gave, so we'll create the callback in any case. if ( $o->get('since') || $o->get('until') ) { if ( $aux_dsn ) { $aux_dbh = get_cxn( for => '--aux', dsn => $aux_dsn, OptionParser => $o, DSNParser => $dp, opts => { AutoCommit => 1 } ); $aux_dbh->{InactiveDestroy} = 1; # Don't die on fork(). } $aux_dbh ||= $qv_dbh || $qh_dbh || $ps_dbh || $ep_dbh; PTDEBUG && _d('aux dbh:', $aux_dbh); my $time_callback = sub { my ( $exp ) = @_; return unless $aux_dbh; my $sql = "SELECT UNIX_TIMESTAMP($exp)"; PTDEBUG && _d($sql); return $aux_dbh->selectall_arrayref($sql)->[0]->[0]; }; if ( $o->get('since') ) { my $since = any_unix_timestamp($o->get('since'), $time_callback); die "Invalid --since value" unless $since; $pipeline->add( name => 'since', process => sub { my ( $args ) = @_; my $event = $args->{event}; return $args unless $event; if ( $args->{past_since} ) { PTDEBUG && _d('Already past --since'); return $args; } if ( $event->{ts} ) { my $ts = any_unix_timestamp($event->{ts}, $time_callback); if ( ($ts || 0) >= $since ) { PTDEBUG && _d('Event is at or past --since'); $args->{past_since} = 1; return $args; } } PTDEBUG && _d('Event is before --since (or ts unknown)'); return; # next event }, ); } if ( $o->get('until') ) { my $until = any_unix_timestamp($o->get('until'), $time_callback); die "Invalid --until value" unless $until; $pipeline->add( name => 'until', process => sub { my ( $args ) = @_; my $event = $args->{event}; return $args unless $event; if ( $args->{at_until} ) { PTDEBUG && _d('Already past --until'); return; } if ( $event->{ts} ) { my $ts = any_unix_timestamp($event->{ts}, $time_callback); if ( ($ts || 0) >= $until ) { PTDEBUG && _d('Event at or after --until'); $args->{at_until} = 1; return; } } PTDEBUG && _d('Event is before --until (or ts unknown)'); return $args; }, ); } } # since/until { # iteration $pipeline->add( # This is a critical proc: if we die here, we probably need # to stop, else an infinite loop can develop: # https://bugs.launchpad.net/percona-toolkit/+bug/888114 # We'll retry twice in case the problem is just one bad # query class, or something like that. retry_on_error => 2, name => 'iteration', process => sub { my ( $args ) = @_; # Start the (next) iteration. if ( !$args->{iter_start} ) { my $iter_start = $args->{iter_start} = time; PTDEBUG && _d('Iteration', $args->{iter}, 'started at', ts($iter_start)); if ( PTDEBUG ) { _d("\n# Iteration $args->{iter} started at ", ts($iter_start), "\n"); } } # Determine if we should stop the current iteration. # If we do, then we report events collected during this # iter, then reset and increment for the next iter. my $report = 0; my $time_left = $args->{time_left}; if ( !$args->{more_events} || defined $time_left && $time_left <= 0 ) { PTDEBUG && _d("Runtime elapsed or no more events, reporting"); $report = 1; } elsif ( $run_time_mode eq 'interval' && $args->{next_ts_interval} && $args->{unix_ts} >= $args->{next_ts_interval} ) { PTDEBUG && _d("Event is in the next interval, reporting"); # Get the next ts interval based on the current log ts. # Log ts can make big jumps, so just += $rt might not # set the next ts interval at a time past the current # log ts. my $rt = $o->get('run-time'); do { $args->{next_ts_interval} += $rt; } until $args->{next_ts_interval} >= $args->{unix_ts}; $report = 1; } if ( $report ) { PTDEBUG && _d("Iteration", $args->{iter}, "stopped at",ts(time)); save_resume_offset( last_event_offset => $parsers[0]->{last_event_offset}, ); # Get this before calling print_reports() because that sub # resets each ea and we may need this later for stats. my $n_events_aggregated = $ea[0]->events_processed(); if ( $n_events_aggregated ) { print_reports( eas => \@ea, tls => \@tl, groupby => \@groupby, orderby => \@orderby, files => \@read_files, Pipeline => $pipeline, QueryReview => $qv, QueryHistory => $qh, %common_modules, ); } else { if ( $o->get('output') eq 'report' ) { print "\n# No events processed.\n"; } } if ( PTDEBUG ) { if ( keys %stats ) { my $report = new ReportFormatter( line_width => 74, ); $report->set_columns( { name => 'Statistic', }, { name => 'Count', right_justify => 1 }, { name => '%/Events', right_justify => 1 }, ); # Have to add this one manually because currently # EventAggregator::aggregate() doesn't know about stats. # It's the same thing as events_processed() though. $stats{events_aggregated} = $n_events_aggregated; # Save value else events_read will be reset during the # foreach loop below and mess up percentage_of(). my $n_events_read = $stats{events_read} || 0; my %stats_sort_order = ( events_read => 1, events_parsed => 2, events_aggregated => 3, ); my @stats = sort { QueryReportFormatter::pref_sort( $a, $stats_sort_order{$a}, $b, $stats_sort_order{$b}) } keys %stats; foreach my $stat ( @stats ) { $report->add_line( $stat, $stats{$stat} || 0, percentage_of( $stats{$stat} || 0, $n_events_read, p => 2), ); $stats{$stat} = 0; # Reset for next iteration. } print STDERR "\n" . $report->get_report(); } else { print STDERR "\n# No statistics values.\n"; } } # Decrement iters_left after finishing an iter because in the # default case, 1 iter, if we decr when the iter starts, then # terminator will think there's no iters left before the one # iter has finished. if ( my $max_iters = $o->get('iterations') ) { $args->{iters_left} = $max_iters - $args->{iter}; PTDEBUG && _d($args->{iters_left}, "iterations left"); } # Next iteration. $args->{iter}++; $args->{iter_start} = undef; # Runtime is per-iteration, so reset it, and reset time_left # else terminator will think runtime has elapsed when really # we may just be between iters. $args->{Runtime}->reset(); $args->{time_left} = undef; } # Continue the pipeline even if we reported and went to the next # iter because there could be an event in the pipeline that is # the first in the next/new iter. return $args; }, ); } # iteration { # terminator $pipeline->add( name => 'terminator', process => sub { my ( $args ) = @_; # The first sure-fire state that terminates the pipeline is # having no more input. if ( !$args->{input_fh} ) { PTDEBUG && _d("No more input, terminating pipeline"); # This shouldn't happen, but I want to know if it does. warn "There's an event in the pipeline but no current input: " . Dumper($args) if $args->{event}; $oktorun = 0; # 2. terminate pipeline return; # 1. exit pipeline early } # The second sure-first state is having no more iterations. my $iters_left = $args->{iters_left}; if ( defined $iters_left && $iters_left <= 0 ) { PTDEBUG && _d("No more iterations, terminating pipeline"); $oktorun = 0; # 2. terminate pipeline return; # 1. exit pipeline early } # There's time or iters left so keep running. if ( $args->{event} ) { PTDEBUG && _d("Event in pipeline, continuing"); return $args; } else { PTDEBUG && _d("No event in pipeline, get next event"); return; } }, ); } # terminator # ######################################################################## # All pipeline processes after the terminator expect an event # (i.e. that $args->{event} exists and is a valid event). # ######################################################################## if ( grep { $_ eq 'fingerprint' } @groupby ) { $pipeline->add( name => 'fingerprint', process => sub { my ( $args ) = @_; my $event = $args->{event}; # Skip events which do not have the groupby attribute. my $groupby_val = $event->{arg}; return unless $groupby_val; $event->{fingerprint} = $qr->fingerprint($groupby_val); return $args; }, ); } # Make subs which map attrib aliases to their primary attrib. foreach my $alt_attrib ( @{$o->get('attribute-aliases')} ) { $pipeline->add( name => 'attribute aliases', process => make_alt_attrib($alt_attrib), ); } # Carry attribs forward for --inherit-attributes. my $inherited_attribs = $o->get('inherit-attributes'); if ( @$inherited_attribs ) { my $last_val = {}; $pipeline->add( name => 'inherit attributes', process => sub { my ( $args ) = @_; my $event = $args->{event}; foreach my $attrib ( @$inherited_attribs ) { if ( defined $event->{$attrib} ) { # Event has val for this attrib; save it as the last val. $last_val->{$attrib} = $event->{$attrib}; } else { # Inherit last val for this attrib (if there was a last val). $event->{$attrib} = $last_val->{$attrib} if defined $last_val->{$attrib}; } } return $args; }, ); } { # variations my @variations = @{$o->get('variations')}; if ( @variations ) { $pipeline->add( name => 'variations', process => sub { my ( $args ) = @_; my $event = $args->{event}; foreach my $attrib ( @variations ) { my $checksum = crc32($event->{$attrib}); $event->{"${attrib}_crc"} = $checksum if defined $checksum; } return $args; }, ); } } # variations if ( grep { $_ eq 'tables' } @groupby ) { $pipeline->add( name => 'tables', process => sub { my ( $args ) = @_; my $event = $args->{event}; my $group_by_val = $event->{arg}; return unless defined $group_by_val; $event->{tables} = [ map { # Canonicalize and add the db name in front $_ =~ s/`//g; if ( $_ !~ m/\./ && (my $db = $event->{db} || $event->{Schema}) ) { $_ = "$db.$_"; } $_; } $qp->get_tables($group_by_val) ]; return $args; }, ); } { # distill my %distill_args; if ( grep { $_ eq 'distill' } @groupby ) { $pipeline->add( name => 'distill', process => sub { my ( $args ) = @_; my $event = $args->{event}; my $group_by_val = $event->{arg}; return unless defined $group_by_val; $event->{distill} = $qr->distill($group_by_val, %distill_args); PTDEBUG && !$event->{distill} && _d('Cannot distill', $event->{arg}); return $args; }, ); } } # distill # Former --zero-admin $pipeline->add( name => 'zero admin', process => sub { my ( $args ) = @_; my $event = $args->{event}; if ( $event->{arg} && $event->{arg} =~ m/^administrator/ ) { $event->{Rows_sent} = 0 if exists $event->{Rows_sent}; $event->{Rows_examined} = 0 if exists $event->{Rows_examined}; $event->{Rows_read} = 0 if exists $event->{Rows_read}; $event->{Rows_affected} = 0 if exists $event->{Rows_affected}; } return $args; }, ); # zero admin # Filter after special attributes, like fingerprint, tables, # distill, etc., have been created. if ( $o->get('filter') ) { my $filter = $o->get('filter'); if ( -f $filter && -r $filter ) { PTDEBUG && _d('Reading file', $filter, 'for --filter code'); open my $fh, "<", $filter or die "Cannot open $filter: $OS_ERROR"; $filter = do { local $/ = undef; <$fh> }; close $fh; } else { $filter = "( $filter )"; # issue 565 } my $code = 'sub { my ( $args ) = @_; my $event = $args->{event}; ' . "$filter && return \$args; };"; PTDEBUG && _d('--filter code:', $code); my $sub = eval $code or die "Error compiling --filter code: $code\n$EVAL_ERROR"; $pipeline->add( name => 'filter', process => $sub, ); } # filter if ( $o->got('sample') ) { my $group_by_val = $groupby[0]; my $num_samples = $o->get('sample'); if ( $group_by_val ) { my %seen; $pipeline->add( name => 'sample', process => sub { my ( $args ) = @_; my $event = $args->{event}; if ( ++$seen{$event->{$group_by_val}} <= $num_samples ) { PTDEBUG && _d("--sample permits event", $event->{$group_by_val}); return $args; } PTDEBUG && _d("--sample rejects event", $event->{$group_by_val}); return; }, ); } } # sample if ( $o->get('output') =~ /slowlog/i ) { my $w = new SlowLogWriter(); $pipeline->add( name => '--output slowlog', process => sub { my ( $args ) = @_; my $event = $args->{event}; PTDEBUG && _d('callback: --output slowlog'); $w->write(*STDOUT, $event); return $args; }, ); } # print # Combine "# Log_slow_rate_type: query Log_slow_rate_limit: 2" # as rate_limit=>'query:2'. $pipeline->add( name => 'rate limit', process => sub { my ( $args ) = @_; my $event = $args->{event}; PTDEBUG && _d('callback: rate limit'); if ( my $limit = $event->{Log_slow_rate_limit} ) { $event->{rate_limit} = ($event->{Log_slow_rate_type} || 'session') . ":$limit"; delete $event->{Log_slow_rate_limit}; delete $event->{Log_slow_rate_type}; } return $args; }, ); # Finally, add aggregator obj for each groupby attrib to the callbacks. # These aggregating objs should be the last pipeline processes. foreach my $i ( 0..$#groupby ) { my $groupby = $groupby[$i]; # This shouldn't happen. die "No --order-by value for --group-by $groupby" unless $orderby[$i]; my ( $orderby_attrib, $orderby_func ) = split(/:/, $orderby[$i]); # Create an EventAggregator for this groupby attrib and # add it to callbacks. my $type_for = { val => 'string', key_print => 'string', Status_code => 'string', Statement_id => 'string', Error_no => 'string', Last_errno => 'string', Thread_id => 'string', InnoDB_trx_id => 'string', host => 'string', ip => 'string', port => 'string', Killed => 'bool', rate_limit => 'string', }; my $ea = new EventAggregator( groupby => $groupby, attributes => { }, worst => $orderby_attrib, attrib_limit => $o->get('attribute-value-limit'), ignore_attributes => $o->get('ignore-attributes'), type_for => $type_for, ); push @ea, $ea; $pipeline->add( name => "aggregate $groupby", process => sub { my ( $args ) = @_; $ea->aggregate($args->{event}); return $args; }, ); # If user wants a timeline report, too, then create an EventTimeline # aggregator for this groupby attrib and add it to the callbacks, too. if ( $o->get('timeline') ) { my $tl = new EventTimeline( groupby => [$groupby], attributes => [qw(Query_time ts)], ); push @tl, $tl; $pipeline->add( name => "timeline $groupby", process => sub { my ( $args ) = @_; $tl->aggregate($args->{event}); return $args; }, ); } } # aggregate # ######################################################################## # Daemonize now that everything is setup and ready to work. # ######################################################################## my $daemon = Daemon->new( daemonize => $o->get('daemonize'), pid_file => $o->get('pid'), log_file => $o->get('log'), ); $daemon->run(); # ######################################################################## # Do the version-check # ######################################################################## if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) { VersionCheck::version_check( force => $o->got('version-check'), instances => [ ($qv_dbh ? { dbh => $qv_dbh, dsn => $review_dsn } : ()), ($qh_dbh ? { dbh => $qh_dbh, dsn => $history_dsn } : ()), ($ps_dbh ? { dbh => $ps_dbh, dsn => $ps_dsn } : ()), ], ); } # ########################################################################## # Parse the input. # ########################################################################## # Pump the pipeline until either no more input, or we're interrupted by # CTRL-C, or--this shouldn't happen--the pipeline causes an error. All # work happens inside the pipeline via the procs we created above. eval { $pipeline->execute( oktorun => \$oktorun, pipeline_data => $pipeline_data, stats => \%stats, ); }; if ( $EVAL_ERROR ) { warn "The pipeline caused an error: $EVAL_ERROR"; } PTDEBUG && _d("Pipeline data:", Dumper($pipeline_data)); save_resume_offset( last_event_offset => $parsers[0]->{last_event_offset}, ); # Disconnect all open $dbh's map { $dp->disconnect($_); PTDEBUG && _d('Disconnected dbh', $_); } grep { $_ } ($qv_dbh, $qh_dbh, $ps_dbh, $ep_dbh, $aux_dbh); return $exit_status; } # End main() # ############################################################################ # Subroutines. # ############################################################################ sub create_review_tables { my ( %args ) = @_; my @required_args = qw(dbh full_table TableParser type); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my $create_table_sql = $args{create_table_sql}; my ($dbh, $full_table, $tp, $type) = @args{@required_args}; PTDEBUG && _d('Checking --review table', $full_table); # If the repl db doesn't exit, auto-create it, maybe. my ($db, $tbl) = Quoter->split_unquote($full_table); my $show_db_sql = qq{SHOW DATABASES LIKE '$db'}; PTDEBUG && _d($show_db_sql); my @db_exists = $dbh->selectrow_array($show_db_sql); if ( !@db_exists && !$args{create_table} ) { die "--$type database $db does not exist and " . "--no-create-$type-table was specified. You need " . "to create the database.\n"; } else { # Even if the db already exists, do this in case it does not exist # on a slave. my $create_db_sql = "CREATE DATABASE IF NOT EXISTS " . Quoter->quote($db) . " /* $tool */"; PTDEBUG && _d($create_db_sql); eval { $dbh->do($create_db_sql); }; if ( $EVAL_ERROR && !@db_exists ) { warn $EVAL_ERROR; die "--$type database $db does not exist and it cannot be " . "created automatically. You need to create the database.\n"; } } # USE the correct db my $sql = "USE " . Quoter->quote($db); PTDEBUG && _d($sql); $dbh->do($sql); # Check if the table exists; if not, create it, maybe. my $tbl_exists = $tp->check_table( dbh => $dbh, db => $db, tbl => $tbl, ); PTDEBUG && _d('Table exists: ', $tbl_exists ? 'yes' : 'no'); if ( !$tbl_exists && !$args{create_table} ) { die "Table $full_table does not exist and " . "--no-create-$type-table was specified. " . "You need to create the table.\n"; } else { PTDEBUG && _d($dbh, $create_table_sql); eval { $dbh->do($create_table_sql); }; if ( $EVAL_ERROR && !$args{create_table} ) { warn $EVAL_ERROR; die "--$type history table $full_table does not exist and it cannot be " . "created automatically. You need to create the table.\n" } } } # TODO: This sub is poorly named since it does more than print reports: # it aggregates, reports, does QueryReview stuff, etc. sub print_reports { my ( %args ) = @_; my @required_args = qw(eas OptionParser); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($o, $qv, $pipeline) = @args{qw(OptionParser QueryReview Pipeline)}; my ($eas, $tls, $stats) = @args{qw(eas tls stats)}; my $qh = $args{QueryHistory}; my @reports = @{$o->get('report-format')}; my @groupby = @{$args{groupby}}; my @orderby = @{$args{orderby}}; my $show_all = $o->get('show-all'); for my $i ( 0..$#groupby ) { if ( $o->get('report') || $qv || $qh ) { $eas->[$i]->calculate_statistical_metrics(); } my ($orderby_attrib, $orderby_func) = split(/:/, $orderby[$i]); $orderby_attrib = check_orderby_attrib($orderby_attrib, $eas->[$i], $o); PTDEBUG && _d('Doing reports for groupby', $groupby[$i], 'orderby', $orderby_attrib, $orderby_func); my ($worst, $other) = get_worst_queries( OptionParser => $o, ea => $eas->[$i], orderby_attrib => $orderby_attrib, orderby_func => $orderby_func, limit => $o->get('limit')->[$i] || '95%:20', outliers => $o->get('outliers')->[$i], ); if ( $o->get('report') ) { # XXX There's a bug here: --expected-range '','' will cause # Use of uninitialized value in numeric lt (<) # This bug is intentionally left unfixed at the moment because # we exploit it to test a more serious bug: an infinite loop: # https://bugs.launchpad.net/percona-toolkit/+bug/888114 my $expected_range = $o->get('expected-range'); my $explain_why = $expected_range && ( @$worst < $expected_range->[0] || @$worst > $expected_range->[1]); # Print a header for this groupby/class if we're doing the # standard query report and there's more than one class or # there's one class but it's not the normal class grouped # by fingerprint. my $print_header = 0; if ( (grep { $_ eq 'query_report'; } @{$o->get('report-format')}) && (@groupby > 1 || $groupby[$i] ne 'fingerprint') ) { $print_header = 1; } my $report_class = $o->get('output') =~ m/^json/i ? 'JSONReportFormatter' : 'QueryReportFormatter'; my $qrf = $report_class->new( dbh => $ep_dbh, QueryReview => $args{QueryReview}, QueryRewriter => $args{QueryRewriter}, OptionParser => $args{OptionParser}, QueryParser => $args{QueryParser}, Quoter => $args{Quoter}, show_all => $show_all, ); $qrf->print_reports( reports => \@reports, ea => $eas->[$i], worst => $worst, other => $other, orderby => $orderby_attrib, groupby => $groupby[$i], print_header => $print_header, explain_why => $explain_why, files => $args{files}, log_type => $o->get('type')->[0], no_v_format => !$o->get('vertical-format'), variations => $o->get('variations'), group => { map { $_=>1 } qw(rusage date hostname files header) }, resume => $resume, anon => $o->get('output') eq 'json-anon', ); } if ( $qv ) { # query review update_query_review_table( ea => $eas->[$i], worst => $worst, QueryReview => $qv, ); } if ( $qh ) { # query history update_query_history_table( ea => $eas->[$i], worst => $worst, QueryHistory => $qh, ); } if ( $o->get('timeline') ) { # --timeline $tls->[$i]->report($tls->[$i]->results(), sub { print @_ }); $tls->[$i]->reset_aggregated_data(); } $eas->[$i]->reset_aggregated_data(); # Reset for next iteration. # Print header report only once. So remove it from the # list of reports after the first groupby's reports. if ( $i == 0 ) { @reports = grep { $_ ne 'header' } @reports; } } # Each groupby if ( PTDEBUG ) { my $report = new ReportFormatter( line_width => 74, ); $report->set_columns( { name => 'Process' }, { name => 'Time', right_justify => 1 }, { name => 'Count', right_justify => 1 }, ); $report->title('Pipeline profile'); my $instrument = $pipeline->instrumentation; my $total_time = $instrument->{Pipeline}; foreach my $process_name ( $pipeline->processes() ) { my $t = $instrument->{$process_name}->{time} || 0; my $tp = sprintf('%.2f %4.1f%%', $t, $t / ($total_time || 1) * 100); $report->add_line($process_name, $tp, $instrument->{$process_name}->{count} || 0); } # Reset profile for next iteration. $pipeline->reset(); _d($report->get_report()); } return; } # Catches signals so we can exit gracefully. sub sig_int { my ( $signal ) = @_; if ( $oktorun ) { print STDERR "# Caught SIG$signal.\n"; $oktorun = 0; } else { print STDERR "# Exiting on SIG$signal.\n"; save_resume_offset(); exit(1); } } # Handle the special defaults for --review & --history sub handle_special_defaults { my ($o, $opt) = @_; my $dsn = $o->get($opt); return unless $dsn; my $para = $o->read_para_after( __FILE__, qr/MAGIC_default_${opt}_table/); my ($default_table) = $para =~ m/default table is C<([^>]+)>/; die "Error parsing special default for --$opt" unless $default_table; my ($D, $t) = Quoter->split_unquote($default_table); $dsn->{D} ||= $D; $dsn->{t} ||= $t; return $dsn; } sub make_alt_attrib { my ( $alt_attrib ) = @_; my @alts = split('\|', $alt_attrib); my $attrib = shift @alts; PTDEBUG && _d('Primary attrib:', $attrib, 'aliases:', @alts); my @lines; push @lines, 'sub { my ( $args ) = @_; ', 'my $event = $args->{event}; ', "if ( exists \$event->{'$attrib'} ) { ", (map { "delete \$event->{'$_'}; "; } @alts), 'return $args; }', # Primary attrib doesn't exist; look for alts (map { "if ( exists \$event->{'$_'} ) { " . "\$event->{'$attrib'} = \$event->{'$_'}; " . "delete \$event->{'$_'}; " . 'return $args; }'; } @alts), 'return $args; }'; PTDEBUG && _d('attrib alias sub for', $attrib, ':', @lines); my $sub = eval join("\n", @lines); die if $EVAL_ERROR; return $sub; } # Checks that the orderby attrib exists in the ea, returns the default # orderby attrib if not. sub check_orderby_attrib { my ( $orderby_attrib, $ea, $o ) = @_; if ( !$ea->type_for($orderby_attrib) && $orderby_attrib ne 'Query_time' ) { my $default_orderby = $o->get_defaults()->{'order-by'}; # Print the notice only if the query report is being printed, too. if ( grep { $_ eq 'query_report' } @{$o->get('report-format')} ) { print "--order-by attribute $orderby_attrib doesn't exist, " . "using $default_orderby\n"; } # Fall back to the default orderby attrib. ( $orderby_attrib, undef ) = split(/:/, $default_orderby); } PTDEBUG && _d('orderby attrib:', $orderby_attrib); return $orderby_attrib; } # Read the fh and timeout after t seconds. sub read_timeout { my ( $fh, $t ) = @_; return unless $fh; $t ||= 0; # will reset alarm and cause read to wait forever # Set the SIGALRM handler. my $mask = POSIX::SigSet->new(&POSIX::SIGALRM); my $action = POSIX::SigAction->new( sub { # This sub is called when a SIGALRM is received. die 'read timeout'; }, $mask, ); my $oldaction = POSIX::SigAction->new(); sigaction(&POSIX::SIGALRM, $action, $oldaction); my $res; eval { alarm $t; $res = <$fh>; alarm 0; }; if ( $EVAL_ERROR ) { PTDEBUG && _d('Read error:', $EVAL_ERROR); die $EVAL_ERROR unless $EVAL_ERROR =~ m/read timeout/; $oktorun = 0; $res = undef; # res is a blank string after a timeout } return $res; } sub get_cxn { my ( %args ) = @_; my @required_args = qw(dsn OptionParser DSNParser); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my ($dsn, $o, $dp) = @args{@required_args}; if ( $o->get('ask-pass') ) { $dsn->{p} = OptionParser::prompt_noecho("Enter password " . ($args{for} ? "for $args{for}: " : ": ")); } my $dbh = $dp->get_dbh($dp->get_cxn_params($dsn), $args{opts}); PTDEBUG && _d('Connected dbh', $dbh); return $dbh; } sub get_worst_queries { my ( %args ) = @_; my $o = $args{OptionParser}; my $ea = $args{ea}; my $orderby_attrib = $args{orderby_attrib}; my $orderby_func = $args{orderby_func}; my $limit = $args{limit}; my $outliers = $args{outliers}; # We don't report on all queries, just the worst, i.e. the top # however many. my ($total, $count); if ( $limit =~ m/^\d+$/ ) { $count = $limit; } else { # It's a percentage, so grab as many as needed to get to # that % of the file. ($total, $count) = $limit =~ m/(\d+)/g; $total *= ($ea->results->{globals}->{$orderby_attrib}->{sum} || 0) / 100; } my %top_spec = ( attrib => $orderby_attrib, orderby => $orderby_func || 'cnt', total => $total, count => $count, ); if ( $args{outliers} ) { @top_spec{qw(ol_attrib ol_limit ol_freq)} = split(/:/, $args{outliers}); } # The queries that will be reported. return $ea->top_events(%top_spec); } sub update_query_review_table { my ( %args ) = @_; foreach my $arg ( qw(ea worst QueryReview) ) { die "I need a $arg argument" unless $args{$arg}; } my $ea = $args{ea}; my $worst = $args{worst}; my $qv = $args{QueryReview}; my $attribs = $ea->get_attributes(); PTDEBUG && _d('Updating query review tables'); foreach my $worst_info ( @$worst ) { my $item = $worst_info->[0]; my $stats = $ea->results->{classes}->{$item}; my $sample = $ea->results->{samples}->{$item}; my $review_vals = $qv->get_review_info($item); $qv->set_review_info( fingerprint => $item, sample => $sample->{arg} || '', first_seen => $stats->{ts}->{min}, last_seen => $stats->{ts}->{max} ); } return; } sub update_query_history_table { my ( %args ) = @_; foreach my $arg ( qw(ea worst QueryHistory) ) { die "I need a $arg argument" unless $args{$arg}; } my $ea = $args{ea}; my $worst = $args{worst}; my $qh = $args{QueryHistory}; my $attribs = $ea->get_attributes(); PTDEBUG && _d('Updating query review tables'); foreach my $worst_info ( @$worst ) { my $item = $worst_info->[0]; my $sample = $ea->results->{samples}->{$item}; my %history; foreach my $attrib ( @$attribs ) { $history{$attrib} = $ea->metrics( attrib => $attrib, where => $item, ); } $qh->set_review_history( $item, $sample->{arg} || '', %history); } return; } # Sub: verify_run_time # Verify that the given run mode and run time are valid. If the run mode # is "interval", the time boundary (in seconds) for the run time is returned # if valid. Else, undef is returned because modes "clock" and "event" have # no boundaries that need to be verified. In any case the sub will die if # something is invalid, so the caller should eval their call. The eval # error message is suitable for . # # Parameters: # %args - Arguments # # Required Arguments: # run_mode - Name of run mode (e.g. "clock", "event" or "interval") # run_time - Run time in seconds # # Returns: # Time boundary in seconds if run mode and time are valid; dies if # they are not. Time boundary is undef except for interval run mode. sub verify_run_time { my ( %args ) = @_; my $run_mode = lc $args{run_mode}; my $run_time = defined $args{run_time} ? lc $args{run_time} : undef; PTDEBUG && _d("Verifying run time mode", $run_mode, "and time", $run_time); die "Invalid --run-time-mode: $run_mode\n" unless $run_mode =~ m/clock|event|interval/; if ( defined $run_time && $run_time < 0 ) { die "--run-time must be greater than zero\n"; } my $boundary; if ( $run_mode eq 'interval' ) { if ( !defined $run_time || $run_time <= 0 ) { die "--run-time must be greater than zero for " . "--run-time-mode $run_mode\n"; } if ( $run_time > 86400 ) { # 1 day # Make sure run time is a whole day and not something like 25h. if ( $run_time % 86400 ) { die "Invalid --run-time argument for --run-time-mode $run_mode; " . "see documentation.\n" } $boundary = $run_time; } else { # If run time is sub-minute (some amount of seconds), it should # divide evenly into minute boundaries. If it's sub-minute # (some amount of minutes), it should divide evenly into hour # boundaries. If it's sub-hour, it should divide eventy into # day boundaries. $boundary = $run_time <= 60 ? 60 # seconds divide into minutes : $run_time <= 3600 ? 3600 # minutes divide into hours : 86400; # hours divide into days if ( $boundary % $run_time ) { die "Invalid --run-time argument for --run-time-mode $run_mode; " . "see documentation.\n" } } } return $boundary; } sub save_resume_offset { my (%args) = @_; my $last_event_offset = $args{last_event_offset}; if ( !$resume_file || !$offset ) { PTDEBUG && _d('Not saving resume offset because there is no ' . 'resume file or offset:', $resume_file, $offset); return; } PTDEBUG && _d('Saving resume at offset', $offset, 'to', $resume_file); open my $resume_fh, '>', $resume_file or die "Error opening $resume_file: $OS_ERROR"; if ( $resume->{simple} ) { print { $resume_fh } $offset, "\n"; warn "\n# Saved resume file offset $offset to $resume_file\n"; } else { # 2.2.3+ enhanced resume file $resume->{stop_offset} = defined $last_event_offset ? $last_event_offset : $offset; foreach my $key ( sort keys %$resume ) { next if $key eq 'simple'; print { $resume_fh } "$key=$resume->{$key}\n"; } warn "\n# Saved resume file stop_offset $resume->{stop_offset} to " . "$resume_file\n"; } close $resume_fh or die "Error close $resume_file: $OS_ERROR"; return; } sub sanitize_event { my ($event) = @_; # Quoted and unquoted values should be treated the same # https://bugs.launchpad.net/percona-toolkit/+bug/1176010 if ( $event->{db} ) { $event->{db} =~ s/^`//; $event->{db} =~ s/`$//; } if ( $event->{Schema} ) { $event->{Schema} =~ s/^`//; $event->{Schema} =~ s/`$//; } return; } # make an effort to check if file is a raw binlog # (i.e. was not converted to text using mysqlbinlog) sub is_raw_binlog { my $filename = shift; return -B $filename; } 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-query-digest - Analyze MySQL queries from logs, processlist, and tcpdump. =head1 SYNOPSIS Usage: pt-query-digest [OPTIONS] [FILES] [DSN] pt-query-digest analyzes MySQL queries from slow, general, and binary log files. It can also analyze queries from C and MySQL protocol data from tcpdump. By default, queries are grouped by fingerprint and reported in descending order of query time (i.e. the slowest queries first). If no C are given, the tool reads C. The optional C is used for certain options like L<"--since"> and L<"--until">. Report the slowest queries from C: pt-query-digest slow.log Report the slowest queries from the processlist on host1: pt-query-digest --processlist h=host1 Capture MySQL protocol data with tcppdump, then report the slowest queries: tcpdump -s 65535 -x -nn -q -tttt -i any -c 1000 port 3306 > mysql.tcp.txt pt-query-digest --type tcpdump mysql.tcp.txt Save query data from C to host2 for later review and trend analysis: pt-query-digest --review h=host2 --no-report slow.log =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-query-digest is a sophisticated but easy to use tool for analyzing MySQL queries. It can analyze queries from MySQL slow, general, and binary logs. (Binary logs must first be converted to text, see L<"--type">). It can also use C and MySQL protocol data from tcpdump. By default, the tool reports which queries are the slowest, and therefore the most important to optimize. More complex and custom-tailored reports can be created by using options like L<"--group-by">, L<"--filter">, and L<"--embedded-attributes">. Query analysis is a best-practice that should be done frequently. To make this easier, pt-query-digest has two features: query review (L<"--review">) and query history (L<"--history">). When the L<"--review"> option is used, all unique queries are saved to a database. When the tool is ran again with L<"--review">, queries marked as reviewed in the database are not printed in the report. This highlights new queries that need to be reviewed. When the L<"--history"> option is used, query metrics (query time, lock time, etc.) for each unique query are saved to database. Each time the tool is ran with L<"--history">, the more historical data is saved which can be used to trend and analyze query performance over time. =head1 ATTRIBUTES pt-query-digest works on events, which are a collection of key-value pairs called attributes. You'll recognize most of the attributes right away: C, C, and so on. You can just look at a slow log and see them. However, there are some that don't exist in the slow log, and slow logs may actually include different kinds of attributes (for example, you may have a server with the Percona patches). See L<"ATTRIBUTES REFERENCE"> near the end of this documentation for a list of common and L<"--type"> specific attributes. A familiarity with these attributes is necessary for working with L<"--filter">, L<"--ignore-attributes">, and other attribute-related options. With creative use of L<"--filter">, you can create new attributes derived from existing attributes. For example, to create an attribute called C for examining the ratio of C to C, specify a filter like: --filter '($event->{Row_ratio} = $event->{Rows_sent} / ($event->{Rows_examined})) && 1' The C<&& 1> trick is needed to create a valid one-line syntax that is always true, even if the assignment happens to evaluate false. The new attribute will automatically appears in the output: # Row ratio 1.00 0.00 1 0.50 1 0.71 0.50 Attributes created this way can be specified for L<"--order-by"> or any option that requires an attribute. =head1 OUTPUT The default L<"--output"> is a query analysis report. The L<"--[no]report"> option controls whether or not this report is printed. Sometimes you may want to parse all the queries but suppress the report, for example when using L<"--review"> or L<"--history">. There is one paragraph for each class of query analyzed. A "class" of queries all have the same value for the L<"--group-by"> attribute which is C by default. (See L<"ATTRIBUTES">.) A fingerprint is an abstracted version of the query text with literals removed, whitespace collapsed, and so forth. The report is formatted so it's easy to paste into emails without wrapping, and all non-query lines begin with a comment, so you can save it to a .sql file and open it in your favorite syntax-highlighting text editor. There is a response-time profile at the beginning. The output described here is controlled by L<"--report-format">. That option allows you to specify what to print and in what order. The default output in the default order is described here. The report, by default, begins with a paragraph about the entire analysis run The information is very similar to what you'll see for each class of queries in the log, but it doesn't have some information that would be too expensive to keep globally for the analysis. It also has some statistics about the code's execution itself, such as the CPU and memory usage, the local date and time of the run, and a list of input file read/parsed. Following this is the response-time profile over the events. This is a highly summarized view of the unique events in the detailed query report that follows. It contains the following columns: Column Meaning ============ ========================================================== Rank The query's rank within the entire set of queries analyzed Query ID The query's fingerprint Response time The total response time, and percentage of overall total Calls The number of times this query was executed R/Call The mean response time per execution V/M The Variance-to-mean ratio of response time Item The distilled query A final line whose rank is shown as MISC contains aggregate statistics on the queries that were not included in the report, due to options such as L<"--limit"> and L<"--outliers">. For details on the variance-to-mean ratio, please see http://en.wikipedia.org/wiki/Index_of_dispersion. Next, the detailed query report is printed. Each query appears in a paragraph. Here is a sample, slightly reformatted so 'perldoc' will not wrap lines in a terminal. The following will all be one paragraph, but we'll break it up for commentary. # Query 2: 0.01 QPS, 0.02x conc, ID 0xFDEA8D2993C9CAF3 at byte 160665 This line identifies the sequential number of the query in the sort order specified by L<"--order-by">. Then there's the queries per second, and the approximate concurrency for this query (calculated as a function of the timespan and total Query_time). Next there's a query ID. This ID is a hex version of the query's checksum in the database, if you're using L<"--review">. You can select the reviewed query's details from the database with a query like 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 results in: Query_id: 0xBDDEB6EDA41897A8.1 SELECT t1 SELECT t2 TLIST t1 TLIST t2 First of all, there are two SELECT contexts, because C and C statements. (This does not include 'SELECT...INTO' statements, which do not return rows but dump output to a file or variable.) If you're using recreatable test or development servers and wish to compare write statements too (e.g. C, C, C), then specify C<--no-read-only>. If using a binary log, you must specify C<--no-read-only> because binary logs don't contain C and C statements. If C<--no-read-only> is specified, I queries are exeucted: C, C, C, etc. Even when running in default read-only mode, you should use a MySQL user with only C on each host before executing each query. The table must be database-qualified. The database and table are automatically created unless C<--no-create-upgrade-table> is specified (see L<"--[no]create-upgrade-table">). If the table does not already exist, it is created with this definition: =for comment ignore-pt-internal-value MAGIC_upgrade_table CREATE TABLE pt_upgrade ( id INT NOT NULL PRIMARY KEY ) =item --user short form: -u; type: string MySQL user if not the current system 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 --watch-server type: string Parse only events for this IP:port for L<"--type"> tcpdump. All other IP addresses are ignored. If not specified, pt-upgrade watches all servers by looking for any IP address using port 3306 or "mysql". If you're watching a server with a non-standard port, this won't work, so you must specify the IP address and port to watch. If you want to watch a mix of servers, some running on standard port 3306 and some running on non-standard ports, you need to create separate tcpdump outputs for the non-standard port servers and then specify this option for each. At present pt-upgrade cannot auto-detect servers on port 3306 and also be told to watch a server on a non-standard port. =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 * 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 re-enable 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 * 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-upgrade ... > 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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C with the name of any tool. =head1 AUTHORS 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2009-2016 Percona LLC and/or its affiliates. Feedback and improvements are welcome. 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 pt-upgrade 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-config-diff0000775000175000017500000051203113021632517020073 0ustar vagrantvagrant#!/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 Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo OptionParser DSNParser Cxn Daemon TextResultSetParser MySQLConfig MySQLConfigComparer ReportFormatter 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.19'; 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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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; 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 = '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"; } $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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2011-2016 Percona LLC and/or its affiliates. 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 pt-config-diff 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-online-schema-change0000775000175000017500000140124413021632517021671 0ustar vagrantvagrant#!/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 OptionParser Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo VersionParser DSNParser Daemon Quoter TableNibbler TableParser Progress Retry Cxn MasterSlave ReplicaLagWaiter FlowControlWaiter MySQLStatusWaiter WeightedAvgRate NibbleIterator Transformers CleanupTask IndexLength HTTP::Micro VersionCheck Percona::XtraDB::Cluster )); } # ########################################################################### # 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.19'; 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 # ########################################################################### # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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; 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 = '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"; } $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 && $tbl->{keys}->{$index}->{is_unique}) { @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) = @_; printf STDERR "$name: %3d%% %s remain\n", $fraction * 100, Transformers::secs_to_time($remaining); }, %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) = @_; 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$|cluster$|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}; my $o = $self->{OptionParser}; $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)); my $slave_dsn = $dsn; if ($o->got('slave-user')) { $slave_dsn->{u} = $o->get('slave-user'); PTDEBUG && _d("Using slave user ".$o->get('slave-user')." on ".$slave_dsn->{h}.":".$slave_dsn->{P}); } if ($o->got('slave-password')) { $slave_dsn->{p} = $o->get('slave-password'); PTDEBUG && _d("Slave password set"); } push @$slaves, $make_cxn->(dsn => $slave_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 FULL 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; my $pr_refresh_slave_list = sub { my ($self) = @_; my ($slaves, $refresher) = ($self->{slaves}, $self->{get_slaves_cb}); return if ( not defined $refresher ); my $before = join ' ', sort map {$_->name()} @$slaves; $slaves = $refresher->(); my $after = join ' ', sort map {$_->name()} @$slaves; if ($before ne $after) { $self->{slaves} = $slaves; printf "Slave set to watch has changed\n Was: %s\n Now: %s\n", $before, $after; } return($self->{slaves}); }; $slaves = $pr_refresh_slave_list->($self); 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'); $slaves = $pr_refresh_slave_list->($self); my $watched = 0; @lagged_slaves = grep { my $slave_name = $_->{cxn}->name(); grep {$slave_name eq $_->name()} @{$slaves || []} } @lagged_slaves; 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; # Backslash found where operator expected at ./pt-online-schema-change line 4933, near "@_ = map { (my $temp = $_) =~ s/\" # (Might be a runaway multi-line // string starting on line 4889) @_ = 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 { $tbl->{tbl_struct}->{type_for}->{$_} eq 'enum' ? "CONCAT(".$q->quote($_).")" : $q->quote($_)} @{$index_cols}); my $order_by_dec = join(' DESC,', map { $tbl->{tbl_struct}->{type_for}->{$_} eq 'enum' ? "CONCAT(".$q->quote($_).")" : $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 " . $order_by_dec . ' 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; $self->{pause_file} = $nibble_params->{pause_file}; $self->{sleep} = $args{sleep} || 60; 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->{pause_file}) { while(-f $self->{pause_file}) { print "Sleeping $self->{sleep} seconds because $self->{pause_file} exists\n"; my $dbh = $self->{Cxn}->dbh(); if ( !$dbh || !$dbh->ping() ) { eval { $dbh = $self->{Cxn}->connect() }; # connect or die trying if ( $EVAL_ERROR ) { chomp $EVAL_ERROR; die "Lost connection to " . $self->{Cxn}->name() . " while waiting for " . "replica lag ($EVAL_ERROR)\n"; } } $dbh->do("SELECT 'nibble iterator keepalive'"); sleep($self->{sleep}); } } 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."; } my $pause_file = ($o->has('pause-file') && $o->get('pause-file')) || undef; 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 pause_file => $pause_file, }; } 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 $best_index; 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; } else { $best_index = $want_index; } } if ( !$best_index && !$want_index && $args{mysql_index} ) { PTDEBUG && _d('MySQL wants to use index', $args{mysql_index}); $want_index = $args{mysql_index}; } my @possible_indexes; if ( !$best_index && $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; } } if (!$best_index) { 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 ? '%1$.'.$p.'f%2$s' : '%1$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'; # 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, ); $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; %ignore_code = (1592 => 1, 1062 => 1); my %stats = ( INSERT => 0, ); # ######################################################################## # Get configuration information. # ######################################################################## my $q = new Quoter(); my $o = new OptionParser(); $o->get_specs(); $o->get_opts(); if ( $o->get('null-to-not-null') ) { $ignore_code{1048} = 1; } 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. # Note: args->{errok} to tolerate connection error my $make_cxn = sub { my (%args) = @_; my $errok = $args{errok}; delete($args{errok}); my $cxn = Cxn->new( %args, DSNParser => $dp, OptionParser => $o, set => $set_on_connect, ); eval { $cxn->connect() }; # connect or die trying if ( $EVAL_ERROR ) { if ($errok) { printf "IGNORING CONNECTION ERROR: %s\n", $EVAL_ERROR; } else { 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, ); my $get_slaves_cb = sub { my ($intolerant) = @_; return( $ms->get_slaves( dbh => $cxn->dbh(), dsn => $cxn->dsn(), make_cxn => sub { return $make_cxn->(@_, prev_dsn => $cxn->dsn(), errok => (not $intolerant)); }, ) ); }; ### first ever call only: do not tolerate connection errors $slaves = $get_slaves_cb->('intolerant'); 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 ]; $get_slaves_cb = undef; } 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, get_slaves_cb => $get_slaves_cb, 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 $sql =~ s/^ CONSTRAINT `(_?)/' CONSTRAINT `'.($1 eq '' ? '_' : '')/gme; if ( $o->get('default-engine') ) { $sql =~ s/\s+ENGINE=\S+//; } if ( $o->get('data-dir') && !$o->got('remove-data-dir') ) { if ( (-d $o->get('data-dir')) && (-w $o->get('data-dir')) ){ $sql =~ s/DATA DIRECTORY='.*?'//; $sql .= sprintf(" DATA DIRECTORY='%s' ",$o->get('data-dir')); PTDEBUG && _d("adding data dir ".$o->get('data-dir')); } else { die $o->get('data-dir') . " is not a directory or it is not writable"; } } if ( $o->got('remove-data-dir') ) { $sql =~ s/DATA DIRECTORY='.*?'//; PTDEBUG && _d("removing data dir"); } 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 = 20; # 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-- ) { # https://bugs.launchpad.net/percona-toolkit/+bug/1526105 if ( $name_tries <= 10 ) { # we've already added 10 underscores? # time to try a small random string my @chars = ("A".."Z", "0".."9"); $prefix = ''; $prefix .= $chars[rand @chars] for 1..6; $prefix .= "_"; } $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, ], operation => "swap_tables", ); }; 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. 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 ) { if ($error =~ /table.+?already exists/i) { PTDEBUG && _d('Aborting retries because of table name conflict. Trying with different name'); } 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(); # 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, similar to the following: Trying to add to index `idx_fk_staff_id` tuple: DATA TUPLE: 2 fields; 0: len 1; hex 05; asc ;; 1: len 4; hex 80000001; asc ;; But the parent table `sakila`.`staff_old` or its .ibd file does not currently exist! This is because the original table (in this case, sakila.staff) was renamed to sakila.staff_old and then dropped. This method of handling foreign key constraints is provided so that the database administrator can disable the tool's built-in functionality if desired. =back =item --[no]analyze-before-swap default: yes Execute ANALYZE TABLE on the new table before swapping with the old one. By default, this happens only when running MySQL 5.6 and newer, and C is enabled. Specify the option explicitly to enable or disable it regardless of MySQL version and C. This circumvents a potentially serious issue related to InnoDB optimizer statistics. If the table being alerted is busy and the tool completes quickly, the new table will not have optimizer statistics after being swapped. This can cause fast, index-using queries to do full table scans until optimizer statistics are updated (usually after 10 seconds). If the table is large and the server very busy, this can cause an outage. =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-alter default: yes Parses the L<"--alter"> specified and tries to warn of possible unintended behavior. Currently, it checks for: =over =item Column renames In previous versions of the tool, renaming a column with C would lead to that column's data being lost. The tool now parses the alter statement and tries to catch these cases, so the renamed columns should have the same data as the originals. However, the code that does this is not a full-blown SQL parser, so you should first run the tool with L<"--dry-run"> and L<"--print"> and verify that it detects the renamed columns correctly. =item DROP PRIMARY KEY If L<"--alter"> contain C (case- and space-insensitive), a warning is printed and the tool exits unless L<"--dry-run"> is specified. Altering the primary key can be dangerous, but the tool can handle it. The tool's triggers, particularly the DELETE trigger, are most affected by altering the primary key because the tool prefers to use the primary key for its triggers. You should first run the tool with L<"--dry-run"> and L<"--print"> and verify that the triggers are correct. =back =item --check-interval type: time; default: 1 Sleep time between checks for L<"--max-lag">. =item --[no]check-plan default: yes Check query execution plans for safety. By default, this option causes the tool to run EXPLAIN before running queries that are meant to access a small amount of data, but which could access many rows if MySQL chooses a bad execution plan. These include the queries to determine chunk boundaries and the chunk queries themselves. If it appears that MySQL will use a bad query execution plan, the tool will skip the chunk of the table. The tool uses several heuristics to determine whether an execution plan is bad. The first is whether EXPLAIN reports that MySQL intends to use the desired index to access the rows. If MySQL chooses a different index, the tool considers the query unsafe. The tool also checks how much of the index MySQL reports that it will use for the query. The EXPLAIN output shows this in the key_len column. The tool remembers the largest key_len seen, and skips chunks where MySQL reports that it will use a smaller prefix of the index. This heuristic can be understood as skipping chunks that have a worse execution plan than other chunks. The tool prints a warning the first time a chunk is skipped due to a bad execution plan in each table. Subsequent chunks are skipped silently, although you can see the count of skipped chunks in the SKIPPED column in the tool's output. This option adds some setup work to each table and chunk. Although the work is not intrusive for MySQL, it results in more round-trips to the server, which consumes time. Making chunks too small will cause the overhead to become relatively larger. It is therefore recommended that you not make chunks too small, because the tool may take a very long time to complete if you do. =item --[no]check-replication-filters default: yes Abort if any replication filter is set on any server. The tool looks for server options that filter replication, such as binlog_ignore_db and replicate_do_db. If it finds any such filters, it aborts with an error. If the replicas are configured with any filtering options, you should be careful not to modify any databases or tables that exist on the master and not the replicas, because it could cause replication to fail. For more information on replication rules, see L. =item --check-slave-lag type: string Pause the data copy until this replica's lag is less than L<"--max-lag">. The value is a DSN that inherits properties from the the connection options (L<"--port">, L<"--user">, etc.). This option overrides the normal behavior of finding and continually monitoring replication lag on ALL connected replicas. If you don't want to monitor ALL replicas, but you want more than just one replica to be monitored, then use the DSN option to the L<"--recursion-method"> option instead of this option. =item --chunk-index type: string Prefer this index for chunking tables. By default, the tool chooses the most appropriate index for chunking. This option lets you specify the index that you prefer. If the index doesn't exist, then the tool will fall back to its default behavior of choosing an index. The tool adds the index to the SQL statements in a C clause. Be careful when using this option; a poor choice of index could cause bad performance. =item --chunk-index-columns type: int Use only this many left-most columns of a L<"--chunk-index">. This works only for compound indexes, and is useful in cases where a bug in the MySQL query optimizer (planner) causes it to scan a large range of rows instead of using the index to locate starting and ending points precisely. This problem sometimes occurs on indexes with many columns, such as 4 or more. If this happens, the tool might print a warning related to the L<"--[no]check-plan"> option. Instructing the tool to use only the first N columns of the index is a workaround for the bug in some cases. =item --chunk-size type: size; default: 1000 Number of rows to select for each chunk copied. Allowable suffixes are k, M, G. This option can override the default behavior, which is to adjust chunk size dynamically to try to make chunks run in exactly L<"--chunk-time"> seconds. When this option isn't set explicitly, its default value is used as a starting point, but after that, the tool ignores this option's value. If you set this option explicitly, however, then it disables the dynamic adjustment behavior and tries to make all chunks exactly the specified number of rows. There is a subtlety: if the chunk index is not unique, then it's possible that chunks will be larger than desired. For example, if a table is chunked by an index that contains 10,000 of a given value, there is no way to write a WHERE clause that matches only 1,000 of the values, and that chunk will be at least 10,000 rows large. Such a chunk will probably be skipped because of L<"--chunk-size-limit">. =item --chunk-size-limit type: float; default: 4.0 Do not copy chunks this much larger than the desired chunk size. When a table has no unique indexes, chunk sizes can be inaccurate. This option specifies a maximum tolerable limit to the inaccuracy. The tool uses to estimate how many rows are in the chunk. If that estimate exceeds the desired chunk size times the limit, then the tool skips the chunk. The minimum value for this option is 1, which means that no chunk can be larger than L<"--chunk-size">. You probably don't want to specify 1, because rows reported by EXPLAIN are estimates, which can be different from the real number of rows in the chunk. You can disable oversized chunk checking by specifying a value of 0. The tool also uses this option to determine how to handle foreign keys that reference the table to be altered. See L<"--alter-foreign-keys-method"> for details. =item --chunk-time type: float; default: 0.5 Adjust the chunk size dynamically so each data-copy query takes this long to execute. The tool tracks the copy rate (rows per second) and adjusts the chunk size after each data-copy query, so that the next query takes this amount of time (in seconds) to execute. It keeps an exponentially decaying moving average of queries per second, so that if the server's performance changes due to changes in server load, the tool adapts quickly. If this option is set to zero, the chunk size doesn't auto-adjust, so query times will vary, but query chunk sizes will not. Another way to do the same thing is to specify a value for L<"--chunk-size"> explicitly, instead of leaving it at the default. =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 --critical-load type: Array; default: Threads_running=50 Examine SHOW GLOBAL STATUS after every chunk, and abort if the load is too high. The option accepts a comma-separated list of MySQL status variables and thresholds. An optional C<=MAX_VALUE> (or C<:MAX_VALUE>) can follow each variable. If not given, the tool determines a threshold by examining the current value at startup and doubling it. See L<"--max-load"> for further details. These options work similarly, except that this option will abort the tool's operation instead of pausing it, and the default value is computed differently if you specify no threshold. The reason for this option is as a safety check in case the triggers on the original table add so much load to the server that it causes downtime. There is probably no single value of Threads_running that is wrong for every server, but a default of 50 seems likely to be unacceptably high for most servers, indicating that the operation should be canceled immediately. =item --database short form: -D; type: string Connect to this database. =item --default-engine Remove C from the new table. By default the new table is created with the same table options as the original table, so if the original table uses InnoDB, then the new table will use InnoDB. In certain cases involving replication, this may cause unintended changes on replicas which use a different engine for the same table. Specifying this option causes the new table to be created with the system's default engine. =item --data-dir type: string Create the new table on a different partition using the DATA DIRECTORY feature. Only available on 5.6+. This parameter is ignored if it is used at the same time than remove-data-dir. =item --remove-data-dir default: no If the original table was created using the DATA DIRECTORY feature, remove it and create the new table in MySQL default directory without creating a new isl file. =item --defaults-file short form: -F; type: string Only read mysql options from the given file. You must give an absolute pathname. =item --[no]drop-new-table default: yes Drop the new table if copying the original table fails. Specifying C<--no-drop-new-table> and C<--no-swap-tables> leaves the new, altered copy of the table without modifying the original table. See L<"--new-table-name">. L<--no-drop-new-table> does not work with C. =item --[no]drop-old-table default: yes Drop the original table after renaming it. After the original table has been successfully renamed to let the new table take its place, and if there are no errors, the tool drops the original table by default. If there are any errors, the tool leaves the original table in place. If C<--no-swap-tables> is specified, then there is no old table to drop. =item --[no]drop-triggers default: yes Drop triggers on the old table. C<--no-drop-triggers> forces C<--no-drop-old-table>. =item --dry-run Create and alter the new table, but do not create triggers, copy data, or replace the original table. =item --execute Indicate that you have read the documentation and want to alter the table. You must specify this option to alter the table. If you do not, then the tool will only perform some safety checks and exit. This helps ensure that you have read the documentation and understand how to use this tool. If you have not read the documentation, then do not specify this option. =item --force This options bypasses confirmation in case of using alter-foreign-keys-method = none , which might break foreign key constraints. =item --help Show help and exit. =item --host short form: -h; type: string Connect to host. =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. A value of 0 would make the tool pause when *any* Flow Control activity is detected. 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 the data copy until all replicas' lag is less than this value. After each data-copy query (each chunk), the tool looks at the replication lag of all replicas to which it connects, using Seconds_Behind_Master. If any replica is lagging more than the value of this option, then the tool will sleep for L<"--check-interval"> seconds, then check all replicas again. If you specify L<"--check-slave-lag">, then the tool only examines that server for lag, not all servers. If you want to control exactly which servers the tool monitors, use the DSN value to L<"--recursion-method">. The tool waits forever for replicas to stop lagging. If any replica is stopped, the tool waits forever until the replica is started. The data copy continues when all replicas are running and not lagging too much. The tool prints progress reports while waiting. If a replica is stopped, it prints a progress report immediately, then again at every progress report interval. =item --max-load type: Array; default: Threads_running=25 Examine SHOW GLOBAL STATUS after every chunk, and pause if any status variables are higher than their thresholds. The option accepts a comma-separated list of MySQL status variables. An optional C<=MAX_VALUE> (or C<:MAX_VALUE>) can follow each variable. If not given, the tool determines a threshold by examining the current value and increasing it by 20%. For example, if you want the tool to pause when Threads_connected gets too high, you can specify "Threads_connected", and the tool will check the current value when it starts working and add 20% to that value. If the current value is 100, then the tool will pause when Threads_connected exceeds 120, and resume working when it is below 120 again. If you want to specify an explicit threshold, such as 110, you can use either "Threads_connected:110" or "Threads_connected=110". The purpose of this option is to prevent the tool from adding too much load to the server. If the data-copy queries are intrusive, or if they cause lock waits, then other queries on the server will tend to block and queue. This will typically cause Threads_running to increase, and the tool can detect that by running SHOW GLOBAL STATUS immediately after each query finishes. If you specify a threshold for this variable, then you can instruct the tool to wait until queries are running normally again. This will not prevent queueing, however; it will only give the server a chance to recover from the queueing. If you notice queueing, it is best to decrease the chunk time. =item --new-table-name type: string; default: %T_new New table name before it is swapped. C<%T> is replaced with the original table name. When the default is used, the tool prefixes the name with up to 10 C<_> (underscore) to find a unique table name. If a table name is specified, the tool does not prefix it with C<_>, so the table must not exist. =item --null-to-not-null Allows MODIFYing a column that allows NULL values to one that doesn't allow them. The rows which contain NULL values will be converted to the defined default value. If no explicit DEFAULT value is given MySQL will assign a default value based on datatype, e.g. 0 for number datatypes, '' for string datatypes. =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 --pause-file type: string Execution will be paused while the file specified by this param exists. =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 file that defines a C class. A plugin allows you to write a Perl module that can hook into many parts of pt-online-schema-change. This requires a good knowledge of Perl and Percona Toolkit conventions, which are beyond this scope of this documentation. Please contact Percona if you have questions or need help. See L<"PLUGIN"> for more information. =item --port short form: -P; type: int Port number to use for connection. =item --print Print SQL statements to STDOUT. Specifying this option allows you to see most of the statements that the tool executes. You can use this option with L<"--dry-run">, for example. =item --progress type: array; default: time,30 Print progress reports to STDERR while copying rows. The value is a comma-separated list with two parts. The first part can be percentage, time, or iterations; the second part specifies how often an update should be printed, in percentage, seconds, or number of iterations. =item --quiet short form: -q Do not print messages to STDOUT (disables L<"--progress">). Errors and warnings are still printed to STDERR. =item --recurse type: int Number of levels to recurse in the hierarchy when discovering replicas. Default is infinite. See also L<"--recursion-method">. =item --recursion-method type: array; default: processlist,hosts Preferred recursion method for discovering replicas. Possible methods are: METHOD USES =========== ================== processlist SHOW PROCESSLIST hosts SHOW SLAVE HOSTS dsn=DSN DSNs from a table none Do not find slaves The processlist method is the default, because SHOW SLAVE HOSTS is not reliable. However, the hosts method can work better if the server uses a non-standard port (not 3306). The tool usually does the right thing and finds all replicas, but you may give a preferred method and it will be used first. The hosts method requires replicas to be configured with report_host, report_port, etc. The dsn method is special: it specifies a table from which other DSN strings are read. The specified DSN must specify a D and t, or a database-qualified t. The DSN table should have the following structure: CREATE TABLE `dsns` ( `id` int(11) NOT NULL AUTO_INCREMENT, `parent_id` int(11) DEFAULT NULL, `dsn` varchar(255) NOT NULL, PRIMARY KEY (`id`) ); To make the tool monitor only the hosts 10.10.1.16 and 10.10.1.17 for replication lag, insert the values C and C into the table. Currently, the DSNs are ordered by id, but id and parent_id are otherwise ignored. You can change the list of hosts while OSC is executing: if you change the contents of the DSN table, OSC will pick it up very soon. =item --slave-user type: string Sets the user to be used to connect to the slaves. This parameter allows you to have a different user with less privileges on the slaves but that user must exist on all slaves. =item --slave-password type: string Sets the password to be used to connect to the slaves. It can be used with --slave-user and the password for the user must be the same on all slaves. =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 innodb_lock_wait_timeout=1 lock_wait_timeout=60 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. Note that setting the C variable requires some tricky escapes to be able to parse the quotes and commas. Example: --set-vars sql_mode=\'STRICT_ALL_TABLES\\,ALLOW_INVALID_DATES\' Note the single backslash for the quotes and double backslash for the comma. =item --sleep type: float; default: 0 How long to sleep (in seconds) after copying each chunk. This option is useful when throttling by L<"--max-lag"> and L<"--max-load"> are not possible. A small, sub-second value should be used, like 0.1, else the tool could take a very long time to copy large tables. =item --socket short form: -S; type: string Socket file to use for connection. =item --statistics Print statistics about internal counters. This is useful to see how many warnings were suppressed compared to the number of INSERT. =item --[no]swap-tables default: yes Swap the original table and the new, altered table. This step completes the online schema change process by making the table with the new schema take the place of the original table. The original table becomes the "old table," and the tool drops it unless you disable L<"--[no]drop-old-table">. =item --tries type: array How many times to try critical operations. If certain operations fail due to non-fatal, recoverable errors, the tool waits and tries the operation again. These are the operations that are retried, with their default number of tries and wait time between tries (in seconds): =for comment ignore-pt-internal-value MAGIC_tries OPERATION TRIES WAIT =================== ===== ==== create_triggers 10 1 drop_triggers 10 1 copy_rows 10 0.25 swap_tables 10 1 update_foreign_keys 10 1 analyze_table 10 1 To change the defaults, specify the new values like: --tries create_triggers:5:0.5,drop_triggers:5:0.5 That makes the tool try C and C 5 times with a 0.5 second wait between tries. So the format is: operation:tries:wait[,operation:tries:wait] All three values must be specified. Note that most operations are affected only in MySQL 5.5 and newer by C (see L<"--set-vars">) because of metadata locks. The C operation is affected in any version of MySQL by C. For creating and dropping triggers, the number of tries applies to each C and C statement for each trigger. For copying rows, the number of tries applies to each chunk, not the entire table. For swapping tables, the number of tries usually applies once because there is usually only one C statement. For rebuilding foreign key constraints, the number of tries applies to each statement (C statements for the C L<"--alter-foreign-keys-method">; other statements for the C method). The tool retries each operation if these errors occur: Lock wait timeout (innodb_lock_wait_timeout and lock_wait_timeout) Deadlock found Query is killed (KILL QUERY ) Connection is killed (KILL CONNECTION ) Lost connection to MySQL In the case of lost and killed connections, the tool will automatically reconnect. Failures and retries are recorded in the L<"--statistics">. =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. =back =head1 PLUGIN The file specified by L<"--plugin"> must define a class (i.e. a package) called C with a C subroutine. The tool will create an instance of this class and call any hooks that it defines. No hooks are required, but a plugin isn't very useful without them. These hooks, in this order, are called if defined: init before_create_new_table after_create_new_table before_alter_new_table after_alter_new_table before_create_triggers after_create_triggers before_copy_rows after_copy_rows before_swap_tables after_swap_tables before_update_foreign_keys after_update_foreign_keys before_drop_old_table after_drop_old_table before_drop_triggers before_exit get_slave_lag Each hook is passed different arguments. To see which arguments are passed to a hook, search for the hook's name in the tool's source code, like: # --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, ); } The comment C<# --plugin hook> precedes every hook call. Here's a plugin file template for all hooks: package pt_online_schema_change_plugin; use strict; sub new { my ($class, %args) = @_; my $self = { %args }; return bless $self, $class; } sub init { my ($self, %args) = @_; print "PLUGIN init\n"; } sub before_create_new_table { my ($self, %args) = @_; print "PLUGIN before_create_new_table\n"; } sub after_create_new_table { my ($self, %args) = @_; print "PLUGIN after_create_new_table\n"; } sub before_alter_new_table { my ($self, %args) = @_; print "PLUGIN before_alter_new_table\n"; } sub after_alter_new_table { my ($self, %args) = @_; print "PLUGIN after_alter_new_table\n"; } sub before_create_triggers { my ($self, %args) = @_; print "PLUGIN before_create_triggers\n"; } sub after_create_triggers { my ($self, %args) = @_; print "PLUGIN after_create_triggers\n"; } sub before_copy_rows { my ($self, %args) = @_; print "PLUGIN before_copy_rows\n"; } sub after_copy_rows { my ($self, %args) = @_; print "PLUGIN after_copy_rows\n"; } sub before_swap_tables { my ($self, %args) = @_; print "PLUGIN before_swap_tables\n"; } sub after_swap_tables { my ($self, %args) = @_; print "PLUGIN after_swap_tables\n"; } sub before_update_foreign_keys { my ($self, %args) = @_; print "PLUGIN before_update_foreign_keys\n"; } sub after_update_foreign_keys { my ($self, %args) = @_; print "PLUGIN after_update_foreign_keys\n"; } sub before_drop_old_table { my ($self, %args) = @_; print "PLUGIN before_drop_old_table\n"; } sub after_drop_old_table { my ($self, %args) = @_; print "PLUGIN after_drop_old_table\n"; } sub before_drop_triggers { my ($self, %args) = @_; print "PLUGIN before_drop_triggers\n"; } sub before_exit { my ($self, %args) = @_; print "PLUGIN before_exit\n"; } sub get_slave_lag { my ($self, %args) = @_; print "PLUGIN get_slave_lag\n"; return sub { return 0; }; } 1; Notice that C must return a function reference; ideally one that returns actual slave lag, not simply zero like in the example. Here's an example that actually does something: package pt_online_schema_change_plugin; use strict; sub new { my ($class, %args) = @_; my $self = { %args }; return bless $self, $class; } sub after_create_new_table { my ($self, %args) = @_; my $new_tbl = $args{new_tbl}; my $dbh = $self->{cxn}->dbh; my $row = $dbh->selectrow_arrayref("SHOW CREATE TABLE $new_tbl->{name}"); warn "after_create_new_table: $row->[1]\n\n"; } sub after_alter_new_table { my ($self, %args) = @_; my $new_tbl = $args{new_tbl}; my $dbh = $self->{cxn}->dbh; my $row = $dbh->selectrow_arrayref("SHOW CREATE TABLE $new_tbl->{name}"); warn "after_alter_new_table: $row->[1]\n\n"; } 1; You could use this with L<"--dry-run"> to check how the table will look before and after. Please contact Percona if you have questions or need help. =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 Database for the old and new 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 * 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 dsn: table; copy: no Table to alter. =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-online-schema-change ... > 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. This tool works only on MySQL 5.0.2 and newer versions, because earlier versions do not support triggers. =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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C with the name of any tool. =head1 AUTHORS Daniel Nichter and Baron Schwartz =head1 ACKNOWLEDGMENTS The "online schema change" concept was first implemented by Shlomi Noach in his tool C, part of L. Engineers at Facebook then built another version called C as explained by their blog post: L. This tool is a hybrid of both approaches, with additional features and functionality not present in either. =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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2011-2016 Percona LLC and/or its affiliates. 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 pt-online-schema-change 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-fingerprint0000775000175000017500000020273513021632517020256 0ustar vagrantvagrant#!/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( OptionParser QueryParser QueryRewriter )); } # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # QueryParser 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/QueryParser.pm # t/lib/QueryParser.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryParser; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; our $tbl_ident = qr/(?:`[^`]+`|\w+)(?:\.(?:`[^`]+`|\w+))?/; our $tbl_regex = qr{ \b(?:FROM|JOIN|(?get_tables($select); } my ($tbl) = $query =~ m/TABLE\s+($tbl_ident)(\s+.*)?/i; PTDEBUG && _d('Matches table:', $tbl); return ($tbl); } $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig; if ( $query =~ s/^\s*LOCK TABLES\s+//i ) { PTDEBUG && _d('Special table type: LOCK TABLES'); $query =~ s/\s+(?:READ(?:\s+LOCAL)?|WRITE)\s*//gi; PTDEBUG && _d('Locked tables:', $query); $query = "FROM $query"; } $query =~ s/\\["']//g; # quoted strings $query =~ s/".*?"/?/sg; # quoted strings $query =~ s/'.*?'/?/sg; # quoted strings my @tables; foreach my $tbls ( $query =~ m/$tbl_regex/gio ) { PTDEBUG && _d('Match tables:', $tbls); next if $tbls =~ m/\ASELECT\b/i; foreach my $tbl ( split(',', $tbls) ) { $tbl =~ s/\s*($tbl_ident)(\s+.*)?/$1/gio; if ( $tbl !~ m/[a-zA-Z]/ ) { PTDEBUG && _d('Skipping suspicious table name:', $tbl); next; } push @tables, $tbl; } } return @tables; } sub has_derived_table { my ( $self, $query ) = @_; my $match = $query =~ m/$has_derived/; PTDEBUG && _d($query, 'has ' . ($match ? 'a' : 'no') . ' derived table'); return $match; } sub get_aliases { my ( $self, $query, $list ) = @_; my $result = { DATABASE => {}, TABLE => {}, }; return $result unless $query; $query =~ s/ (?:LOW_PRIORITY|IGNORE|STRAIGHT_JOIN)//ig; $query =~ s/ (?:INNER|OUTER|CROSS|LEFT|RIGHT|NATURAL)//ig; my @tbl_refs; my ($tbl_refs, $from) = $query =~ m{ ( (FROM|INTO|UPDATE)\b\s* # Keyword before table refs .+? # Table refs ) (?:\s+|\z) # If the query does not end with the table (?:WHERE|ORDER|LIMIT|HAVING|SET|VALUES|\z) # Keyword after table refs }ix; if ( $tbl_refs ) { if ( $query =~ m/^(?:INSERT|REPLACE)/i ) { $tbl_refs =~ s/\([^\)]+\)\s*//; } PTDEBUG && _d('tbl refs:', $tbl_refs); my $before_tbl = qr/(?:,|JOIN|\s|$from)+/i; my $after_tbl = qr/(?:,|JOIN|ON|USING|\z)/i; $tbl_refs =~ s/ = /=/g; while ( $tbl_refs =~ m{ $before_tbl\b\s* ( ($tbl_ident) (?:\s+ (?:AS\s+)? (\w+))? ) \s*$after_tbl }xgio ) { my ( $tbl_ref, $db_tbl, $alias ) = ($1, $2, $3); PTDEBUG && _d('Match table:', $tbl_ref); push @tbl_refs, $tbl_ref; $alias = $self->trim_identifier($alias); if ( $tbl_ref =~ m/^AS\s+\w+/i ) { PTDEBUG && _d('Subquery', $tbl_ref); $result->{TABLE}->{$alias} = undef; next; } my ( $db, $tbl ) = $db_tbl =~ m/^(?:(.*?)\.)?(.*)/; $db = $self->trim_identifier($db); $tbl = $self->trim_identifier($tbl); $result->{TABLE}->{$alias || $tbl} = $tbl; $result->{DATABASE}->{$tbl} = $db if $db; } } else { PTDEBUG && _d("No tables ref in", $query); } if ( $list ) { return \@tbl_refs; } else { return $result; } } sub split { my ( $self, $query ) = @_; return unless $query; $query = $self->clean_query($query); PTDEBUG && _d('Splitting', $query); my $verbs = qr{SELECT|INSERT|UPDATE|DELETE|REPLACE|UNION|CREATE}i; my @split_statements = grep { $_ } split(m/\b($verbs\b(?!(?:\s*\()))/io, $query); my @statements; if ( @split_statements == 1 ) { push @statements, $query; } else { for ( my $i = 0; $i <= $#split_statements; $i += 2 ) { push @statements, $split_statements[$i].$split_statements[$i+1]; if ( $statements[-2] && $statements[-2] =~ m/on duplicate key\s+$/i ) { $statements[-2] .= pop @statements; } } } PTDEBUG && _d('statements:', map { $_ ? "<$_>" : 'none' } @statements); return @statements; } sub clean_query { my ( $self, $query ) = @_; return unless $query; $query =~ s!/\*.*?\*/! !g; # Remove /* comment blocks */ $query =~ s/^\s+//; # Remove leading spaces $query =~ s/\s+$//; # Remove trailing spaces $query =~ s/\s{2,}/ /g; # Remove extra spaces return $query; } sub split_subquery { my ( $self, $query ) = @_; return unless $query; $query = $self->clean_query($query); $query =~ s/;$//; my @subqueries; my $sqno = 0; # subquery number my $pos = 0; while ( $query =~ m/(\S+)(?:\s+|\Z)/g ) { $pos = pos($query); my $word = $1; PTDEBUG && _d($word, $sqno); if ( $word =~ m/^\(?SELECT\b/i ) { my $start_pos = $pos - length($word) - 1; if ( $start_pos ) { $sqno++; PTDEBUG && _d('Subquery', $sqno, 'starts at', $start_pos); $subqueries[$sqno] = { start_pos => $start_pos, end_pos => 0, len => 0, words => [$word], lp => 1, # left parentheses rp => 0, # right parentheses done => 0, }; } else { PTDEBUG && _d('Main SELECT at pos 0'); } } else { next unless $sqno; # next unless we're in a subquery PTDEBUG && _d('In subquery', $sqno); my $sq = $subqueries[$sqno]; if ( $sq->{done} ) { PTDEBUG && _d('This subquery is done; SQL is for', ($sqno - 1 ? "subquery $sqno" : "the main SELECT")); next; } push @{$sq->{words}}, $word; my $lp = ($word =~ tr/\(//) || 0; my $rp = ($word =~ tr/\)//) || 0; PTDEBUG && _d('parentheses left', $lp, 'right', $rp); if ( ($sq->{lp} + $lp) - ($sq->{rp} + $rp) == 0 ) { my $end_pos = $pos - 1; PTDEBUG && _d('Subquery', $sqno, 'ends at', $end_pos); $sq->{end_pos} = $end_pos; $sq->{len} = $end_pos - $sq->{start_pos}; } } } for my $i ( 1..$#subqueries ) { my $sq = $subqueries[$i]; next unless $sq; $sq->{sql} = join(' ', @{$sq->{words}}); substr $query, $sq->{start_pos} + 1, # +1 for ( $sq->{len} - 1, # -1 for ) "__subquery_$i"; } return $query, map { $_->{sql} } grep { defined $_ } @subqueries; } sub query_type { my ( $self, $query, $qr ) = @_; my ($type, undef) = $qr->distill_verbs($query); my $rw; if ( $type =~ m/^SELECT\b/ ) { $rw = 'read'; } elsif ( $type =~ m/^$data_manip_stmts\b/ || $type =~ m/^$data_def_stmts\b/ ) { $rw = 'write' } return { type => $type, rw => $rw, } } sub get_columns { my ( $self, $query ) = @_; my $cols = []; return $cols unless $query; my $cols_def; if ( $query =~ m/^SELECT/i ) { $query =~ s/ ^SELECT\s+ (?:ALL |DISTINCT |DISTINCTROW |HIGH_PRIORITY |STRAIGHT_JOIN |SQL_SMALL_RESULT |SQL_BIG_RESULT |SQL_BUFFER_RESULT |SQL_CACHE |SQL_NO_CACHE |SQL_CALC_FOUND_ROWS )\s+ /SELECT /xgi; ($cols_def) = $query =~ m/^SELECT\s+(.+?)\s+FROM/i; } elsif ( $query =~ m/^(?:INSERT|REPLACE)/i ) { ($cols_def) = $query =~ m/\(([^\)]+)\)\s*VALUE/i; } PTDEBUG && _d('Columns:', $cols_def); if ( $cols_def ) { @$cols = split(',', $cols_def); map { my $col = $_; $col = s/^\s+//g; $col = s/\s+$//g; $col; } @$cols; } return $cols; } sub parse { my ( $self, $query ) = @_; return unless $query; my $parsed = {}; $query =~ s/\n/ /g; $query = $self->clean_query($query); $parsed->{query} = $query, $parsed->{tables} = $self->get_aliases($query, 1); $parsed->{columns} = $self->get_columns($query); my ($type) = $query =~ m/^(\w+)/; $parsed->{type} = lc $type; $parsed->{sub_queries} = []; return $parsed; } sub extract_tables { my ( $self, %args ) = @_; my $query = $args{query}; my $default_db = $args{default_db}; my $q = $self->{Quoter} || $args{Quoter}; return unless $query; PTDEBUG && _d('Extracting tables'); my @tables; my %seen; foreach my $db_tbl ( $self->get_tables($query) ) { next unless $db_tbl; next if $seen{$db_tbl}++; # Unique-ify for issue 337. my ( $db, $tbl ) = $q->split_unquote($db_tbl); push @tables, [ $db || $default_db, $tbl ]; } return @tables; } sub trim_identifier { my ($self, $str) = @_; return unless defined $str; $str =~ s/`//g; $str =~ s/^\s+//; $str =~ s/\s+$//; return $str; } 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 QueryParser package # ########################################################################### # ########################################################################### # QueryRewriter 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/QueryRewriter.pm # t/lib/QueryRewriter.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package QueryRewriter; use strict; use warnings FATAL => 'all'; use English qw(-no_match_vars); use constant PTDEBUG => $ENV{PTDEBUG} || 0; our $verbs = qr{^SHOW|^FLUSH|^COMMIT|^ROLLBACK|^BEGIN|SELECT|INSERT |UPDATE|DELETE|REPLACE|^SET|UNION|^START|^LOCK}xi; my $quote_re = qr/"(?:(?!(? [^()]+ ) # Non-parens without backtracking | (??{ $bal }) # Group with matching parens )* \) /x; my $olc_re = qr/(?:--|#)[^'"\r\n]*(?=[\r\n]|\Z)/; # One-line comments my $mlc_re = qr#/\*[^!].*?\*/#sm; # But not /*!version */ my $vlc_re = qr#/\*.*?[0-9+].*?\*/#sm; # For SHOW + /*!version */ my $vlc_rf = qr#^(SHOW).*?/\*![0-9+].*?\*/#sm; # Variation for SHOW sub new { my ( $class, %args ) = @_; my $self = { %args }; return bless $self, $class; } sub strip_comments { my ( $self, $query ) = @_; return unless $query; $query =~ s/$mlc_re//go; $query =~ s/$olc_re//go; if ( $query =~ m/$vlc_rf/i ) { # contains show + version $query =~ s/$vlc_re//go; } return $query; } sub shorten { my ( $self, $query, $length ) = @_; $query =~ s{ \A( (?:INSERT|REPLACE) (?:\s+LOW_PRIORITY|DELAYED|HIGH_PRIORITY|IGNORE)? (?:\s\w+)*\s+\S+\s+VALUES\s*\(.*?\) ) \s*,\s*\(.*?(ON\s+DUPLICATE|\Z)} {$1 /*... omitted ...*/$2}xsi; return $query unless $query =~ m/IN\s*\(\s*(?!select)/i; my $last_length = 0; my $query_length = length($query); while ( $length > 0 && $query_length > $length && $query_length < ( $last_length || $query_length + 1 ) ) { $last_length = $query_length; $query =~ s{ (\bIN\s*\() # The opening of an IN list ([^\)]+) # Contents of the list, assuming no item contains paren (?=\)) # Close of the list } { $1 . __shorten($2) }gexsi; } return $query; } sub __shorten { my ( $snippet ) = @_; my @vals = split(/,/, $snippet); return $snippet unless @vals > 20; my @keep = splice(@vals, 0, 20); # Remove and save the first 20 items return join(',', @keep) . "/*... omitted " . scalar(@vals) . " items ...*/"; } sub fingerprint { my ( $self, $query ) = @_; $query =~ m#\ASELECT /\*!40001 SQL_NO_CACHE \*/ \* FROM `# # mysqldump query && return 'mysqldump'; $query =~ m#/\*\w+\.\w+:[0-9]/[0-9]\*/# # pt-table-checksum, etc query && return 'percona-toolkit'; $query =~ m/\Aadministrator command: / && return $query; $query =~ m/\A\s*(call\s+\S+)\(/i && return lc($1); # Warning! $1 used, be careful. if ( my ($beginning) = $query =~ m/\A((?:INSERT|REPLACE)(?: IGNORE)?\s+INTO.+?VALUES\s*\(.*?\))\s*,\s*\(/is ) { $query = $beginning; # Shorten multi-value INSERT statements ASAP } $query =~ s/$mlc_re//go; $query =~ s/$olc_re//go; $query =~ s/\Ause \S+\Z/use ?/i # Abstract the DB in USE && return $query; $query =~ s/\\["']//g; # quoted strings $query =~ s/".*?"/?/sg; # quoted strings $query =~ s/'.*?'/?/sg; # quoted strings if ( $self->{match_md5_checksums} ) { $query =~ s/([._-])[a-f0-9]{32}/$1?/g; } if ( !$self->{match_embedded_numbers} ) { $query =~ s/[0-9+-][0-9a-f.xb+-]*/?/g; } else { $query =~ s/\b[0-9+-][0-9a-f.xb+-]*/?/g; } if ( $self->{match_md5_checksums} ) { $query =~ s/[xb+-]\?/?/g; } else { $query =~ s/[xb.+-]\?/?/g; } $query =~ s/\A\s+//; # Chop off leading whitespace chomp $query; # Kill trailing whitespace $query =~ tr[ \n\t\r\f][ ]s; # Collapse whitespace $query = lc $query; $query =~ s/\bnull\b/?/g; # Get rid of NULLs $query =~ s{ # Collapse IN and VALUES lists \b(in|values?)(?:[\s,]*\([\s?,]*\))+ } {$1(?+)}gx; $query =~ s{ # Collapse UNION \b(select\s.*?)(?:(\sunion(?:\sall)?)\s\1)+ } {$1 /*repeat$2*/}xg; $query =~ s/\blimit \?(?:, ?\?| offset \?)?/limit ?/; # LIMIT if ( $query =~ m/\bORDER BY /gi ) { # Find, anchor on ORDER BY clause 1 while $query =~ s/\G(.+?)\s+ASC/$1/gi && pos $query; } return $query; } sub distill_verbs { my ( $self, $query ) = @_; $query =~ m/\A\s*call\s+(\S+)\(/i && return "CALL $1"; $query =~ m/\A\s*use\s+/ && return "USE"; $query =~ m/\A\s*UNLOCK TABLES/i && return "UNLOCK"; $query =~ m/\A\s*xa\s+(\S+)/i && return "XA_$1"; if ( $query =~ m/\Aadministrator command:/ ) { $query =~ s/administrator command:/ADMIN/; $query = uc $query; return $query; } $query = $self->strip_comments($query); if ( $query =~ m/\A\s*SHOW\s+/i ) { PTDEBUG && _d($query); $query = uc $query; $query =~ s/\s+(?:GLOBAL|SESSION|FULL|STORAGE|ENGINE)\b/ /g; $query =~ s/\s+COUNT[^)]+\)//g; $query =~ s/\s+(?:FOR|FROM|LIKE|WHERE|LIMIT|IN)\b.+//ms; $query =~ s/\A(SHOW(?:\s+\S+){1,2}).*\Z/$1/s; $query =~ s/\s+/ /g; PTDEBUG && _d($query); return $query; } eval $QueryParser::data_def_stmts; eval $QueryParser::tbl_ident; my ( $dds ) = $query =~ /^\s*($QueryParser::data_def_stmts)\b/i; if ( $dds) { my ( $obj ) = $query =~ m/$dds.+(DATABASE|TABLE)\b/i; $obj = uc $obj if $obj; PTDEBUG && _d('Data def statment:', $dds, 'obj:', $obj); my ($db_or_tbl) = $query =~ m/(?:TABLE|DATABASE)\s+($QueryParser::tbl_ident)(\s+.*)?/i; PTDEBUG && _d('Matches db or table:', $db_or_tbl); return uc($dds . ($obj ? " $obj" : '')), $db_or_tbl; } my @verbs = $query =~ m/\b($verbs)\b/gio; @verbs = do { my $last = ''; grep { my $pass = $_ ne $last; $last = $_; $pass } map { uc } @verbs; }; if ( ($verbs[0] || '') eq 'SELECT' && @verbs > 1 ) { PTDEBUG && _d("False-positive verbs after SELECT:", @verbs[1..$#verbs]); my $union = grep { $_ eq 'UNION' } @verbs; @verbs = $union ? qw(SELECT UNION) : qw(SELECT); } my $verb_str = join(q{ }, @verbs); return $verb_str; } sub __distill_tables { my ( $self, $query, $table, %args ) = @_; my $qp = $args{QueryParser} || $self->{QueryParser}; die "I need a QueryParser argument" unless $qp; my @tables = map { $_ =~ s/`//g; $_ =~ s/(_?)[0-9]+/$1?/g; $_; } grep { defined $_ } $qp->get_tables($query); push @tables, $table if $table; @tables = do { my $last = ''; grep { my $pass = $_ ne $last; $last = $_; $pass } @tables; }; return @tables; } sub distill { my ( $self, $query, %args ) = @_; if ( $args{generic} ) { my ($cmd, $arg) = $query =~ m/^(\S+)\s+(\S+)/; return '' unless $cmd; $query = (uc $cmd) . ($arg ? " $arg" : ''); } else { my ($verbs, $table) = $self->distill_verbs($query, %args); if ( $verbs && $verbs =~ m/^SHOW/ ) { my %alias_for = qw( SCHEMA DATABASE KEYS INDEX INDEXES INDEX ); map { $verbs =~ s/$_/$alias_for{$_}/ } keys %alias_for; $query = $verbs; } else { my @tables = $self->__distill_tables($query, $table, %args); $query = join(q{ }, $verbs, @tables); } } if ( $args{trf} ) { $query = $args{trf}->($query, %args); } return $query; } sub convert_to_select { my ( $self, $query ) = @_; return unless $query; return if $query =~ m/=\s*\(\s*SELECT /i; $query =~ s{ \A.*? update(?:\s+(?:low_priority|ignore))?\s+(.*?) \s+set\b(.*?) (?:\s*where\b(.*?))? (limit\s*[0-9]+(?:\s*,\s*[0-9]+)?)? \Z } {__update_to_select($1, $2, $3, $4)}exsi || $query =~ s{ \A.*? (?:insert(?:\s+ignore)?|replace)\s+ .*?\binto\b(.*?)\(([^\)]+)\)\s* values?\s*(\(.*?\))\s* (?:\blimit\b|on\s+duplicate\s+key.*)?\s* \Z } {__insert_to_select($1, $2, $3)}exsi || $query =~ s{ \A.*? (?:insert(?:\s+ignore)?|replace)\s+ (?:.*?\binto)\b(.*?)\s* set\s+(.*?)\s* (?:\blimit\b|on\s+duplicate\s+key.*)?\s* \Z } {__insert_to_select_with_set($1, $2)}exsi || $query =~ s{ \A.*? delete\s+(.*?) \bfrom\b(.*) \Z } {__delete_to_select($1, $2)}exsi; $query =~ s/\s*on\s+duplicate\s+key\s+update.*\Z//si; $query =~ s/\A.*?(?=\bSELECT\s*\b)//ism; return $query; } sub convert_select_list { my ( $self, $query ) = @_; $query =~ s{ \A\s*select(.*?)\bfrom\b } {$1 =~ m/\*/ ? "select 1 from" : "select isnull(coalesce($1)) from"}exi; return $query; } sub __delete_to_select { my ( $delete, $join ) = @_; if ( $join =~ m/\bjoin\b/ ) { return "select 1 from $join"; } return "select * from $join"; } sub __insert_to_select { my ( $tbl, $cols, $vals ) = @_; PTDEBUG && _d('Args:', @_); my @cols = split(/,/, $cols); PTDEBUG && _d('Cols:', @cols); $vals =~ s/^\(|\)$//g; # Strip leading/trailing parens my @vals = $vals =~ m/($quote_re|[^,]*${bal}[^,]*|[^,]+)/g; PTDEBUG && _d('Vals:', @vals); if ( @cols == @vals ) { return "select * from $tbl where " . join(' and ', map { "$cols[$_]=$vals[$_]" } (0..$#cols)); } else { return "select * from $tbl limit 1"; } } sub __insert_to_select_with_set { my ( $from, $set ) = @_; $set =~ s/,/ and /g; return "select * from $from where $set "; } sub __update_to_select { my ( $from, $set, $where, $limit ) = @_; return "select $set from $from " . ( $where ? "where $where" : '' ) . ( $limit ? " $limit " : '' ); } sub wrap_in_derived { my ( $self, $query ) = @_; return unless $query; return $query =~ m/\A\s*select/i ? "select 1 from ($query) as x limit 1" : $query; } 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 QueryRewriter 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_fingerprint; use English qw(-no_match_vars); use Data::Dumper; $Data::Dumper::Indent = 1; $OUTPUT_AUTOFLUSH = 1; use constant PTDEBUG => $ENV{PTDEBUG} || 0; sub main { @ARGV = @_; # set global ARGV for this package # ########################################################################## # Get configuration information. # ########################################################################## my $o = new OptionParser(); $o->get_specs(); $o->get_opts(); $o->usage_or_errors(); my $qp = new QueryParser(); my $qr = new QueryRewriter( QueryParser => $qp, match_md5_checksums => $o->get('match-md5-checksums'), match_embedded_numbers => $o->get('match-embedded-numbers'), ); if ( $o->got('query') ) { print $qr->fingerprint($o->get('query')), "\n"; } else { local $INPUT_RECORD_SEPARATOR = ";\n"; while ( <> ) { my $query = $_; chomp $query; $query =~ s/^#.+$//mg; $query =~ s/^\s+//; next unless $query =~ m/^\w/; print $qr->fingerprint($query), "\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-fingerprint - Convert queries into fingerprints. =head1 SYNOPSIS Usage: pt-fingerprint [OPTIONS] [FILES] pt-fingerprint converts queries into fingerprints. With the --query option, converts the option's value into a fingerprint. With no options, treats command-line arguments as FILEs and reads and converts semicolon-separated queries from the FILEs. When FILE is -, it read standard input. Convert a single query: pt-fingerprint --query "select a, b, c from users where id = 500" Convert a file full of queries: pt-fingerprint /path/to/file.txt =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 A query fingerprint is the abstracted form of a query, which makes it possible to group similar queries together. Abstracting a query removes literal values, normalizes whitespace, and so on. For example, consider these two queries: SELECT name, password FROM user WHERE id='12823'; select name, password from user where id=5; Both of those queries will fingerprint to select name, password from user where id=? Once the query's fingerprint is known, we can then talk about a query as though it represents all similar queries. Query fingerprinting accommodates a great many special cases, which have proven necessary in the real world. For example, an IN list with 5 literals is really equivalent to one with 4 literals, so lists of literals are collapsed to a single one. If you want to understand more about how and why all of these cases are handled, please review the test cases in the Subversion repository. If you find something that is not fingerprinted properly, please submit a bug report with a reproducible test case. Here is a list of transformations during fingerprinting, which might not be exhaustive: =over =item * Group all SELECT queries from mysqldump together, even if they are against different tables. Ditto for all of pt-table-checksum's checksum queries. =item * Shorten multi-value INSERT statements to a single VALUES() list. =item * Strip comments. =item * Abstract the databases in USE statements, so all USE statements are grouped together. =item * Replace all literals, such as quoted strings. For efficiency, the code that replaces literal numbers is somewhat non-selective, and might replace some things as numbers when they really are not. Hexadecimal literals are also replaced. NULL is treated as a literal. Numbers embedded in identifiers are also replaced, so tables named similarly will be fingerprinted to the same values (e.g. users_2009 and users_2010 will fingerprint identically). =item * Collapse all whitespace into a single space. =item * Lowercase the entire query. =item * Replace all literals inside of IN() and VALUES() lists with a single placeholder, regardless of cardinality. =item * Collapse multiple identical UNION queries into a single one. =back =head1 OPTIONS This tool accepts additional command-line arguments. Refer to the L<"SYNOPSIS"> and usage information for details. =over =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 --help Show help and exit. =item --match-embedded-numbers Match numbers embedded in words and replace as single values. This option causes the tool to be more careful about matching numbers so that words with numbers, like C are matched and replaced as a single C placeholder. Otherwise the default number matching pattern will replace C as C. This is helpful if database or table names contain numbers. =item --match-md5-checksums Match MD5 checksums and replace as single values. This option causes the tool to be more careful about matching numbers so that MD5 checksums like C are matched and replaced as a single C placeholder. Otherwise, the default number matching pattern will replace C as C. =item --query type: string The query to convert into a fingerprint. =item --version Show version and exit. =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-fingerprint ... > 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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2011-2016 Percona LLC and/or its affiliates. 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 pt-fingerprint 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-slave-delay0000775000175000017500000043422113021632517020132 0ustar vagrantvagrant#!/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 OptionParser Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo DSNParser Daemon Transformers Retry 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.19'; 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 # ########################################################################### # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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; 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 = '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"; } $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 # ########################################################################### # ########################################################################### # 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 ? '%1$.'.$p.'f%2$s' : '%1$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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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_delay; use English qw(-no_match_vars); use List::Util qw(min max); use sigtrap qw(handler finish untrapped normal-signals); Transformers->import(qw(ts)); use Percona::Toolkit; use constant PTDEBUG => $ENV{PTDEBUG} || 0; my $now; my $o; my $oktorun = 1; sub main { local @ARGV = @_; # set global ARGV for this package $o = new OptionParser(); $o->get_specs(); $o->get_opts(); my $dp = $o->DSNParser(); $dp->prop('set-vars', $o->set_vars()); my $dsn_defaults = $dp->parse_options($o); my $slave_dsn = @ARGV ? $dp->parse(shift @ARGV, $dsn_defaults) : $dsn_defaults; my $master_dsn = $dp->parse(shift @ARGV, $slave_dsn, $dsn_defaults) if @ARGV; if ( !$o->got('help') ) { if ( !$slave_dsn ) { $o->save_error("Missing or invalid slave host"); } } $o->set('interval', max($o->get('interval'), 1)); if ( $o->get('run-time') ) { $o->set('run-time', max($o->get('run-time'), 1)); } $o->usage_or_errors(); # ####################################################################### # Ready to work now. # ####################################################################### my ( $TS, $FILE, $POS ) = ( 0, 1, 2 ); my @positions; my $next_start = 0; $now = time(); my $end = $now + ( $o->get('run-time') || 0 ); # When we should exit # Connect before daemonizing, in case --ask-pass is needed. my $slave_dbh = get_dbh($dp, $slave_dsn); my $status = $slave_dbh->selectrow_hashref("SHOW SLAVE STATUS"); if ( !$status || ! %$status ) { die "No SLAVE STATUS found"; } if ( ( $status->{slave_sql_running} || '' ) eq 'No' ) { # http://code.google.com/p/maatkit/issues/detail?id=1169 die "Slave SQL thread is not running"; } my $master_dbh; if ( $master_dsn ) { PTDEBUG && _d('Connecting to master via DSN from cmd-line'); $master_dbh = get_dbh($dp, $master_dsn); } elsif ( $o->get('use-master') || $status->{slave_io_state} =~ m/free enough relay log/ ) { # Try to connect to the slave's master just by looking at its # SLAVE STATUS. PTDEBUG && _d('The I/O thread is waiting, connecting to master'); my $spec = "h=$status->{master_host},P=$status->{master_port}"; $master_dbh = get_dbh($dp, $dp->parse($spec, $slave_dsn)); } # 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(); } # ######################################################################## # Do the version-check # ######################################################################## if ( $o->get('version-check') && (!$o->has('quiet') || !$o->get('quiet')) ) { my $tmp_master_dsn = $master_dsn ? $master_dsn : {h=>$status->{master_host}, P=>$status->{master_port}}; VersionCheck::version_check( force => $o->got('version-check'), instances => [ { dbh => $slave_dbh, dsn => $slave_dsn }, { dbh => $master_dbh, dsn => $tmp_master_dsn } ], ); } # ######################################################################## # Main loop # ######################################################################## # If the I/O thread isn't running when the program starts, # it never knows what to do. So start it. $slave_dbh->do('START SLAVE IO_THREAD'); while ( # Quit if: (!$o->get('run-time') || $now < $end) # time is exceeded && $oktorun # or instructed to quit ) { $now = time(); # If the database connection is gone, we must live on! # Try 10 times, for about 2 minutes, to reconnect to the slave, # increasing wait time from 3 to 15 seconds. $o->set('ask-pass', 0); # don't ask again my $tries = 10; my $rt = new Retry(); $rt->retry( tries => $tries, try => sub { return unless $oktorun; $status = $slave_dbh->selectrow_hashref("SHOW SLAVE STATUS"); return $status; }, fail => sub { return unless $oktorun; }, final_fail => sub { die "Failed to reconnect to slave"; }, wait => sub { my ( %args ) = @_; return unless $oktorun; my $t = min($args{tryno} * 3, 15); info("Lost connection, sleeping $t seconds " . "and trying " . ($tries-$args{tryno}) . " more times") if $tries - $args{tryno}; sleep $t; info("Trying to reconnect"); eval { $slave_dbh = get_dbh($dp, $slave_dsn); }; }, ); last unless $oktorun; # might have gotten interrupt while waiting if ( !$status || ! %$status ) { die "No SLAVE STATUS found"; } if ( !$master_dbh && $status->{slave_io_state} =~ m/free enough relay log/ ) { PTDEBUG && _d("The I/O thread is stuck, connecting to master"); # If we're daemonized and --ask-pass is given, there's no way # to ask for a password. if ( $o->get('daemonize') && $o->get('ask-pass') ) { die "Cannot ask for password while daemonized"; } my $spec = "h=$status->{master_host},P=$status->{master_port}"; $master_dbh = get_dbh($dp, $dp->parse($spec, $slave_dsn)); } if ( defined $status->{seconds_behind_master} ) { info("slave running $status->{seconds_behind_master} seconds behind"); } # Get binlog position. if ( $master_dbh ) { PTDEBUG && _d('Getting binlog pos from master'); my $res = $master_dbh->selectrow_hashref("SHOW MASTER STATUS"); die "Binary logging is disabled on the MASTER_DSN" unless $res && %$res && $res->{file}; my $pos = $positions[-1]; if ( !@positions || $pos->[$FILE] ne $res->{file} || $pos->[$POS] != $res->{position} ) { push @positions, [ $now, $res->{file}, $res->{position} ]; } } else { PTDEBUG && _d('Getting binlog pos from slave'); # Use the position on master at which the I/O thread is reading. # If the I/O thread is not far behind, which it usually is not, # this is basically the same as the master's File/Position, but # it's more efficient -- one fewer connections to keep open. my $pos = $positions[-1]; if ( !@positions || $pos->[$FILE] ne $status->{master_log_file} || $pos->[$POS] != $status->{read_master_log_pos} ) { push @positions, [ # Bug 962330: pt-slave-delay incorrectly computes lag if # started when slave is already lagging. # That happened because for an already lagged slave, $now # isn't the correct time, but is actually # $now - $seconds_lagged. $now - ( $status->{seconds_behind_master} || 0 ), $status->{master_log_file}, $status->{read_master_log_pos} ]; } } if ( ( $status->{slave_sql_running} || '' ) eq 'No' ) { PTDEBUG && _d('Slave not running'); # Find the most recent binlog position that's older than # the delay amount. my $pos; my $i = 0; while ( $i < @positions && $positions[$i]->[$TS] <= $now - $o->get('delay') ) { $pos = $i; $i++; } if ( $pos ) { my $position = $positions[$pos]; PTDEBUG && _d('Chosen position:', ts($position->[$TS]), $position->[$FILE], '/', $position->[$POS]); } else { PTDEBUG && _d('No position found'); } # Make the slave server delay if possible; otherwise sleep and check # again. if ( $now >= $next_start && defined $pos ) { my $position = $positions[$pos]; if ( $position->[$FILE] ne $status->{relay_master_log_file} || $position->[$POS] != $status->{exec_master_log_pos} ) { $slave_dbh->do( "START SLAVE SQL_THREAD UNTIL /*$position->[$TS]*/ " . "MASTER_LOG_FILE = '$position->[$FILE]', " . "MASTER_LOG_POS = $position->[$POS]" ); info("START SLAVE until master " . ts($position->[$TS]) . " $position->[$FILE]/$position->[$POS]"); } else { info("no new binlog events"); } # Throw away positions we're going to replicate past. @positions = @positions[$pos + 1 .. $#positions]; } else { my $position = $positions[-1]; info("slave stopped at master position " . "$position->[$FILE]/$position->[$POS]"); } } elsif ( ($status->{seconds_behind_master} || 0) < $o->get('delay') ) { my $position = $positions[-1]; my $behind = $status->{seconds_behind_master} || 0; $next_start = $now + $o->get('delay') - $behind; info("STOP SLAVE until " . ts($next_start) . " at master position $position->[$FILE]/$position->[$POS]"); $slave_dbh->do("STOP SLAVE SQL_THREAD"); } else { my $position = $positions[-1]; my $behind = $status->{seconds_behind_master} || 0; info("slave running $behind seconds behind at" . " master position $position->[$FILE]/$position->[$POS]"); } sleep($o->get('interval')); } if ( $slave_dbh && $o->get('continue') ) { info("Setting slave to run normally"); $slave_dbh->do("START SLAVE SQL_THREAD"); } return 0; } # ############################################################################ # Subroutines # ############################################################################ sub info { my ( $message ) = @_; $o->get('quiet') ? PTDEBUG && _d('info: now:', $now, 'message:', $message) : print ts($now), " ", $message, "\n"; } # Catches signals so pt-slave-delay can exit gracefully. sub finish { my ($signal) = @_; print STDERR "Exiting on SIG$signal.\n"; $oktorun = 0; } sub get_dbh { my ( $dp, $info, $db ) = @_; if ( $o->get('ask-pass') ) { $info->{p} = OptionParser::prompt_noecho( "Enter password" . ($info->{h} ? " for $info->{h}: " : ": ")); } my $dbh = $dp->get_dbh( $dp->get_cxn_params($info), {AutoCommit => 1}); $dbh->{FetchHashKeyName} = 'NAME_lc'; # Lowercases all column names $dbh->{InactiveDestroy} = 1; # Don't disconnect on fork return $dbh; } 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-delay - Make a MySQL slave server lag behind its master. =head1 SYNOPSIS Usage: pt-slave-delay [OPTIONS] SLAVE_DSN [MASTER_DSN] pt-slave-delay starts and stops a slave server as needed to make it lag behind the master. The SLAVE_DSN and MASTER_DSN use DSN syntax, and values are copied from the SLAVE_DSN to the MASTER_DSN if omitted. To hold slavehost one minute behind its master for ten minutes: pt-slave-delay --delay 1m --interval 15s --run-time 10m slavehost =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 C watches a slave and starts and stops its replication SQL thread as necessary to hold it at least as far behind the master as you request. In practice, it will typically cause the slave to lag between L<"--delay"> and L<"--delay">+L<"--interval"> behind the master. It bases the delay on binlog positions in the slave's relay logs by default, so there is no need to connect to the master. This works well if the IO thread doesn't lag the master much, which is typical in most replication setups; the IO thread lag is usually milliseconds on a fast network. If your IO thread's lag is too large for your purposes, C can also connect to the master for information about binlog positions. If the slave's I/O thread reports that it is waiting for the SQL thread to free some relay log space, C will automatically connect to the master to find binary log positions. If L<"--ask-pass"> and L<"--daemonize"> are given, it is possible that this could cause it to ask for a password while daemonized. In this case, it exits. Therefore, if you think your slave might encounter this condition, you should be sure to either specify L<"--use-master"> explicitly when daemonizing, or don't specify L<"--ask-pass">. The SLAVE_DSN and optional MASTER_DSN are both DSNs. See L<"DSN OPTIONS">. Missing MASTER_DSN values are filled in with values from SLAVE_DSN, so you don't need to specify them in both places. C reads all normal MySQL option files, such as ~/.my.cnf, so you may not need to specify username, password and other common options at all. C tries to exit gracefully by trapping signals such as Ctrl-C. You cannot bypass L<"--[no]continue"> with a trappable signal. =head1 PRIVILEGES pt-slave-delay requires the following privileges: PROCESS, REPLICATION CLIENT, and SUPER. =head1 OUTPUT If you specify L<"--quiet">, there is no output. Otherwise, the normal output is a status message consisting of a timestamp and information about what C is doing: starting the slave, stopping the slave, or just observing. =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. =item --[no]continue default: yes Continue replication normally on exit. After exiting, restart the slave's SQL thread with no UNTIL condition, so it will run as usual and catch up to the master. This is enabled by default and works even if you terminate C with Control-C. =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 --defaults-file short form: -F; type: string Only read mysql options from the given file. You must give an absolute pathname. =item --delay type: time; default: 1h How far the slave should lag its master. =item --help Show help and exit. =item --host short form: -h; type: string Connect to host. =item --interval type: time; default: 1m How frequently C should check whether the slave needs to be started or stopped. =item --log type: string Print all output to this file when daemonized. =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 Don't print informational messages about operation. See L for details. =item --run-time type: time How long C should run before exiting. The default is to run forever. =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 --use-master Get binlog positions from master, not slave. Don't trust the binlog positions in the slave's relay log. Connect to the master and get binlog positions instead. If you specify this option without giving a MASTER_DSN on the command line, C examines the slave's SHOW SLAVE STATUS to determine the hostname and port for connecting to the master. C uses only the MASTER_HOST and MASTER_PORT values from SHOW SLAVE STATUS for the master connection. It does not use the MASTER_USER value. If you want to specify a different username for the master than the one you use to connect to the slave, you should specify the MASTER_DSN option explicitly on the command line. =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. =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-slave-delay ... > 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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C with the name of any tool. =head1 AUTHORS Sergey Zhuravlev and 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2011-2016 Percona LLC and/or its affiliates, 2007-2011 Sergey Zhuravle and Baron Schwartz. 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 pt-slave-delay 2.2.20 =cut percona-toolkit-2.2.20/bin/pt-deadlock-logger0000775000175000017500000050450213021632517020747 0ustar vagrantvagrant#!/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 OptionParser Lmo::Utils Lmo::Meta Lmo::Object Lmo::Types Lmo VersionParser Quoter DSNParser Cxn Daemon HTTP::Micro VersionCheck Runtime )); } # ########################################################################### # 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.19'; 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 # ########################################################################### # ########################################################################### # 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] =~/^--config=/ ) { $ARGV[0] = substr($ARGV[0],9); $ARGV[0] =~ s/^'(.*)'$/$1/; $ARGV[0] =~ s/^"(.*)"$/$1/; $self->_set_option('config', shift @ARGV); } 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"; exit 0; } 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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # 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 = 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; 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 = '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"; } $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 # ########################################################################### # ########################################################################### # 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 # ########################################################################### # ########################################################################### # Runtime 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/Runtime.pm # t/lib/Runtime.t # See https://launchpad.net/percona-toolkit for more information. # ########################################################################### { package Runtime; 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(now); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless exists $args{$arg}; } my $run_time = $args{run_time}; if ( defined $run_time ) { die "run_time must be > 0" if $run_time <= 0; } my $now = $args{now}; die "now must be a callback" unless ref $now eq 'CODE'; my $self = { run_time => $run_time, now => $now, start_time => undef, end_time => undef, time_left => undef, stop => 0, }; return bless $self, $class; } sub time_left { my ( $self, %args ) = @_; if ( $self->{stop} ) { PTDEBUG && _d("No time left because stop was called"); return 0; } my $now = $self->{now}->(%args); PTDEBUG && _d("Current time:", $now); if ( !defined $self->{start_time} ) { $self->{start_time} = $now; } return unless defined $now; my $run_time = $self->{run_time}; return unless defined $run_time; if ( !$self->{end_time} ) { $self->{end_time} = $now + $run_time; PTDEBUG && _d("End time:", $self->{end_time}); } $self->{time_left} = $self->{end_time} - $now; PTDEBUG && _d("Time left:", $self->{time_left}); return $self->{time_left}; } sub have_time { my ( $self, %args ) = @_; my $time_left = $self->time_left(%args); return 1 if !defined $time_left; # run forever return $time_left <= 0 ? 0 : 1; # <=0s means run time has elapsed } sub time_elapsed { my ( $self, %args ) = @_; my $start_time = $self->{start_time}; return 0 unless $start_time; my $now = $self->{now}->(%args); PTDEBUG && _d("Current time:", $now); my $time_elapsed = $now - $start_time; PTDEBUG && _d("Time elapsed:", $time_elapsed); if ( $time_elapsed < 0 ) { warn "Current time $now is earlier than start time $start_time"; } return $time_elapsed; } sub reset { my ( $self ) = @_; $self->{start_time} = undef; $self->{end_time} = undef; $self->{time_left} = undef; $self->{stop} = 0; PTDEBUG && _d("Reset run time"); return; } sub stop { my ( $self ) = @_; $self->{stop} = 1; return; } sub start { my ( $self ) = @_; $self->{stop} = 0; 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 Runtime 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_deadlock_logger; use English qw(-no_match_vars); use List::Util qw(max); use Socket qw(inet_aton); use Time::HiRes qw(sleep); use File::Temp qw(tempfile); use File::Spec; use sigtrap 'handler', \&sig_int, 'normal-signals'; use Percona::Toolkit; use constant PTDEBUG => $ENV{PTDEBUG} || 0; # Some common patterns and variables my $d = qr/(\d+)/; # Digit my $t = qr/((?:\d+ \d+)|(?:[A-Fa-f0-9]+))/; # Transaction ID my $i = qr/((?:\d{1,3}\.){3}\d+)/; # IP address my $n = qr/([^`\s]+)/; # MySQL object name my $u = qr/(\S+)/; # Username. This is somewhat wrong, but # usernames with spaces are rare enough. my $s = qr/((?:\d{6}|\d{4}-\d\d-\d\d) .\d:\d\d:\d\d)(?: [xA-Fa-f0-9]+)?/; # InnoDB timestamp # A thread's proc_info can be at least 98 different things I've found in the # source. Fortunately, most of them begin with a gerunded verb. These are # the ones that don't. my %is_proc_info = ( 'After create' => 1, 'Execution of init_command' => 1, 'FULLTEXT initialization' => 1, 'Reopen tables' => 1, 'Repair done' => 1, 'Repair with keycache' => 1, 'System lock' => 1, 'Table lock' => 1, 'Thread initialized' => 1, 'User lock' => 1, 'copy to tmp table' => 1, 'discard_or_import_tablespace' => 1, 'end' => 1, 'got handler lock' => 1, 'got old table' => 1, 'init' => 1, 'key cache' => 1, 'locks' => 1, 'malloc' => 1, 'query end' => 1, 'rename result table' => 1, 'rename' => 1, 'setup' => 1, 'statistics' => 1, 'status' => 1, 'table cache' => 1, 'update' => 1, ); my $oktorun = 1; my $exit_status = 0; sub main { local @ARGV = @_; # set global ARGV for this package $oktorun = 1; $exit_status = 0; # ######################################################################## # Get configuration information. # ######################################################################## my $o = new OptionParser(); $o->get_specs(); $o->get_opts(); my $dp = $o->DSNParser(); $dp->prop('set-vars', $o->set_vars()); my $src = Cxn->new( dsn_string => shift @ARGV, parent => $o->get('daemonize'), DSNParser => $dp, OptionParser => $o, ); my $dst; if ( my $dst_dsn = $o->get('dest') ) { # set time_zone = SYSTEM , addresses https://bugs.launchpad.net/percona-toolkit/+bug/1295667 my $set_tz = sub { my ($dbh) = @_; my $sql = "SET time_zone=SYSTEM /* pt-deadlock-logger */"; eval { PTDEBUG && _d($dbh, $sql); $dbh->do($sql); }; if ( $EVAL_ERROR ) { die "Failed to $sql: $EVAL_ERROR\n"; } }; $dst = Cxn->new( dsn => $dst_dsn, prev_dsn => ($src ? $src->dsn : undef), parent => $o->get('daemonize'), DSNParser => $dp, OptionParser => $o, set => $set_tz, ); } if ( !$o->get('help') ) { if ( !$src ) { $o->save_error('No DSN was specified.'); } if ( $dst && !$dst->dsn->{D} ) { $o->save_error("--dest requires a 'D' (database) part."); } if ( $dst && !$dst->dsn->{t} ) { $o->save_error("--dest requires a 't' (table) part."); } } $o->usage_or_errors(); # ######################################################################## # Connect to MySQL and set up the --dest, if any. # ######################################################################## my $q = new Quoter(); $src->connect(); my @cols = @{ $o->get('columns') }; my $ins_sth; my $ins_sql; if ( $dst ) { $dst->connect(AutoCommit => 0); my $db_tbl = $q->join_quote($dst->dsn->{D}, $dst->dsn->{t}); my $cols = join(',', map { $q->quote($_) } @cols); my $parms = join(',', map { '?' } @cols); $ins_sql = "INSERT IGNORE INTO $db_tbl ($cols) VALUES ($parms) " . "/* pt-deadlock-logger */"; PTDEBUG && _d($ins_sql); $ins_sth = $dst->dbh->prepare($ins_sql); if ( $o->get('create-dest-table') ) { my $sql = $o->read_para_after(__FILE__, qr/MAGIC_dest_table/); $sql =~ s/deadlocks/IF NOT EXISTS $db_tbl/; PTDEBUG && _d($sql); $dst->dbh->do($sql); } } # ######################################################################## # 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(); } # If we daemonized, the parent has already exited and we're the child. # We shared a copy of every Cxn with the parent, and the parent's copies # were destroyed but the dbhs were not disconnected because the parent # attrib was true. Now, as the child, set it false so the dbhs will be # disconnected when our Cxn copies are destroyed. If we didn't daemonize, # then we're not really a parent (since we have no children), so set it # false to auto-disconnect the dbhs when our Cxns are destroyed. $src->{parent} = 0; $dst->{parent} = 0 if $dst; # ######################################################################## # 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 } : ()) ], ); } # ######################################################################## # Set upt the --clear-deadlocks table. # ######################################################################## my $clear_deadlocks_table_def; my $clear_deadlocks_table = $o->get('clear-deadlocks'); if ( $clear_deadlocks_table ) { $clear_deadlocks_table_def = $o->read_para_after(__FILE__, qr/MAGIC_clear_deadlocks/); if ( VersionParser->new($src->dbh) < '4.1.2') { $clear_deadlocks_table_def =~ s/ENGINE=/TYPE=/; } $clear_deadlocks_table_def =~ s/percona_schema.clear_deadlocks/$clear_deadlocks_table/; PTDEBUG && _d('--clear-deadlocks table:', $clear_deadlocks_table_def); } # ######################################################################## # Start looking for and logging deadlocks. # ######################################################################## my $sep = $o->get('tab') ? "\t" : ' '; my $last_fingerprint = ''; my $parse_deadlocks_options = { 'server' => $src->dsn->{h} || $src->{hostname}, 'numeric-ip' => $o->got('numeric-ip'), }; my $run_time = Runtime->new( run_time => $o->get('run-time'), now => sub { return time }, ); my $interval = $o->get('interval'); my $iters = $o->get('iterations'); PTDEBUG && _d('iterations:', $iters, 'interval:', $interval); ITERATION: while ( $oktorun && $run_time->have_time() && (!defined $iters || $iters--) ) { my %txns; my $fingerprint; eval { my $sql = "SHOW /*!40100 ENGINE*/ INNODB STATUS " . "/* pt-deadlock-logger */"; my $text = $src->dbh->selectrow_hashref($sql)->{status}; %txns = %{parse_deadlocks($text, $parse_deadlocks_options)}; $fingerprint = fingerprint(\%txns); }; if ( my $e = $EVAL_ERROR ) { PTDEBUG && _d('Error getting InnoDB status:', $e); if ( $src->lost_connection($e) ) { eval { $src->connect() }; if ( $EVAL_ERROR ) { warn "Lost connection to " . $src->name . ". Will try " . "to reconnect in the next iteration.\n"; } else { PTDEBUG && _d('Reconnected to MySQL'); redo ITERATION; } } else { warn "Error getting SHOW ENGINE INNODB STATUS: $EVAL_ERROR"; $exit_status |= 1; } } else { if ( $fingerprint ne $last_fingerprint ) { PTDEBUG && _d('New deadlock'); if ( $ins_sth ) { eval { PTDEBUG && _d('Saving deadlock to --dest'); foreach my $txn ( sort { $a->{thread} <=> $b->{thread} } values %txns ) { $ins_sth->execute(@{$txn}{@cols}); } $dst->dbh->commit(); }; if ( my $e = $EVAL_ERROR ) { PTDEBUG && _d('Error saving to --dest:', $e); if ( $dst->lost_connection($e) ) { eval { $ins_sth->finish() if $ins_sth; $dst->dbh->disconnect() if $dst->dbh; $dst->connect(AutoCommit => 0); $ins_sth = $dst->dbh->prepare($ins_sql); }; if ( $EVAL_ERROR ) { warn "Lost connection to " . $dst->name . ". Will try " . "to reconnect in the next iteration.\n"; } else { PTDEBUG && _d('Reconnected to MySQL (--dest)'); redo ITERATION; } } else { warn "Error saving to --dest: $EVAL_ERROR"; $exit_status |= 1; } } } if ( !$o->get('quiet') ) { print join($sep, @cols), "\n"; foreach my $txn ( sort { $a->{thread} <=> $b->{thread} } values %txns ) { $txn->{query} =~ s/\s+/ /g; print join($sep, map { $txn->{$_} } @cols), "\n"; } } } else { PTDEBUG && _d('Same deadlock, not printing'); } $last_fingerprint = $fingerprint; if ( $clear_deadlocks_table ) { clear_deadlocks( dsn => $src->dsn, table => $clear_deadlocks_table, table_def => $clear_deadlocks_table_def, DSNParser => $dp, ); } } # Sleep if there's an --iteration left. if ( !defined $iters || $iters ) { PTDEBUG && _d('Sleeping', $interval, 'seconds'); sleep $interval; } } PTDEBUG && _d('Done running, exiting', $exit_status); return $exit_status; } # ############################################################################ # Subroutines # ############################################################################ sub parse_deadlocks { my ( $text, $args ) = @_; $args ||= {}; # Pull out the deadlock section my $dl_text; my @matches = $text =~ m#\n(---+)\n([A-Z /]+)\n\1\n(.*?)(?=\n(---+)\n[A-Z /]+\n\4\n|$)#gs; while ( my ( $start, $name, $text, $end ) = splice(@matches, 0, 4) ) { next unless $name eq 'LATEST DETECTED DEADLOCK'; $dl_text = $text; last; } return {} unless $dl_text; my @sections = $dl_text =~ m{ ^\*{3}\s([^\n]*) # *** (1) WAITING FOR THIS... (.*?) # Followed by anything, non-greedy (?=(?:^\*{3})|\z) # Followed by another three-stars or EOF }gmsx; # Loop through each section. There are no assumptions about how many # there are, who holds and wants what locks, and who gets rolled back. my %txns; while ( my ($header, $body) = splice(@sections, 0, 2) ) { my ( $txn_id, $what ) = $header =~ m/^\($d\) (.*):$/m; next unless $txn_id; $txns{$txn_id} ||= { id => $txn_id }; my $hash = $txns{$txn_id}; if ( $what eq 'TRANSACTION' ) { @{$hash}{qw(txn_time)} = $body =~ m/ACTIVE $d sec/; # Parsing the line that begins 'MySQL thread id' is complicated. # The only thing always in the line is the thread and query id. # See function innobase_mysql_print_thd in InnoDB source file # sql/ha_innodb.cc. my ( $thread_line ) = $body =~ m/^(MySQL thread id .*)$/m; my ($mysql_thread_id, $query_id, $hostname, $ip, $user, $query_status); if ( $thread_line ) { # These parts can always be gotten. ( $mysql_thread_id, $query_id ) = $thread_line =~ m/^MySQL thread id $d,.* query id $d/m; # If it's a master/slave thread, "Has (read|sent) all" may be the # thread's proc_info. In these cases, there won't be any # host/ip/user info. ( $query_status ) = $thread_line =~ m/(Has (?:read|sent) all .*$)/m; if ( defined($query_status) ) { $user = 'system user'; } # The query id might be the last thing in the line. elsif ( $thread_line =~ m/query id \d+ / ) { # The IP address is the only non-word thing left, so it's # the most useful marker for where I have to start guessing. ( $hostname, $ip ) = $thread_line =~ m/query id \d+(?: ([A-Za-z]\S+))? $i/m; if ( defined $ip ) { ($user, $query_status) = $thread_line =~ m/$ip $u(?: (.*))?$/; } else { # OK, there wasn't an IP address. # There might not be ANYTHING except the query status. ( $query_status ) = $thread_line =~ m/query id \d+ (.*)$/; if ( $query_status !~ m/^\w+ing/ && !exists($is_proc_info{$query_status}) ) { # The remaining tokens are, in order: hostname, user, # query_status. # It's basically impossible to know which is which. ( $hostname, $user, $query_status ) = $thread_line =~ m/query id \d+(?: ([A-Za-z]\S+))?(?: $u(?: (.*))?)?$/m; } else { $user = 'system user'; } } } } my ( $query_text ) = $body =~ m/\nMySQL thread id .*\n((?s).*)/; $query_text =~ s/\s+$//; $query_text =~ s/\s+/ /g; @{$hash}{qw(thread hostname ip user query)} = ($mysql_thread_id, $hostname, $ip, $user, $query_text); foreach my $key ( keys %$hash ) { if ( !defined $hash->{$key} ) { $hash->{$key} = ''; } } } else { # Prefer information about locks waited-for over locks-held. if ( $what eq 'WAITING FOR THIS LOCK TO BE GRANTED' || !$hash->{lock_type} ) { $hash->{wait_hold} = $what eq 'WAITING FOR THIS LOCK TO BE GRANTED' ? 'w' : 'h'; @{$hash}{ qw(lock_type idx db tbl txn_id lock_mode) } = $body =~ m{^(RECORD|TABLE) LOCKS? (?:space id \d+ page no \d+ n bits \d+ index `?$n`? of )?table `$n(?:/|`\.`)$n`.*?trx id $t lock.mode (\S+)}m; if ( $hash->{txn_id} ) { my ( $high, $low ) = $hash->{txn_id} =~ m/^(\d+) (\d+)$/; $hash->{txn_id} = $high ? ( $low + ($high << 32) ) : $low; } } } # Ensure all values are defined map { $hash->{$_} = 0 unless defined $hash->{$_} } qw(thread txn_id txn_time); map { $hash->{$_} = '' unless defined $hash->{$_} } qw(user hostname db tbl idx lock_type lock_mode query); } # Extract some miscellaneous data from the deadlock. my ( $ts ) = $dl_text =~ m/^$s$/m; if ( !$ts ) { # https://bugs.launchpad.net/percona-toolkit/+bug/1195034 # 130624 17:39:24TOO DEEP OR LONG SEARCH IN THE LOCK TABLE ... ($ts) = $dl_text =~ m/^${s}TOO DEEP/m; } my ( $year, $mon, $day, $hour, $min, $sec ) = $ts =~ m/^((?:\d\d)?\d\d)-?(\d\d)-?(\d\d) +(\d+):(\d+):(\d+)$/; if ( length($year) == 2 ) { $year += 2000; } $ts = sprintf('%02d-%02d-%02dT%02d:%02d:%02d', $year, $mon, $day, $hour, $min, $sec); my ( $victim ) = $dl_text =~ m/^\*\*\* WE ROLL BACK TRANSACTION \((\d+)\)$/m; $victim ||= 0; # Stick the misc data into the transactions. foreach my $txn ( values %txns ) { $txn->{victim} = $txn->{id} == $victim ? 1 : 0; $txn->{ts} = $ts; $txn->{server} = $args->{server} || ''; $txn->{ip} = inet_aton($txn->{ip}) if $args->{'numeric-ip'}; } return \%txns; } sub clear_deadlocks { my (%args) = @_; my @required_args = qw(dsn table table_def DSNParser); foreach my $arg ( @required_args ) { die "I need a $arg argument" unless $args{$arg}; } my $dsn = $args{dsn}; my $table = $args{table}; my $table_def = $args{table_def}; my $dp = $args{DSNParser}; PTDEBUG && _d('Clearing deadlocks with table', $table, $table_def); my $parent_dbh = $dp->get_dbh($dp->get_cxn_params($dsn), { AutoCommit=>0 }); $parent_dbh->{InactiveDestroy} = 1; # because of forking # Create the deadlocks table. PTDEBUG && _d($table_def); $parent_dbh->do($table_def); # Get a lock on it. my $sql = "INSERT INTO $table (a) VALUES (1) " . "/* pt-deadlock-logger clear deadlocks parent */"; PTDEBUG && _d($sql); $parent_dbh->do($sql); my ($sync_fh, $sync_file) = tempfile( 'pt-deadlock-logger-clear-deadlocks.XXXXXXX', DIR => File::Spec->tmpdir(), ); PTDEBUG && _d('Sync file:', $sync_file); close $sync_fh; unlink $sync_file; # Fork a child to try to take a lock on the table. my $pid = fork(); if ( defined($pid) && $pid == 0 ) { # I am the child PTDEBUG && _d('Clear deadlocks child', $PID); my $child_dbh = $dp->get_dbh($dp->get_cxn_params($dsn), {AutoCommit=>0}); my $sql = "SELECT * FROM $table FOR UPDATE " . "/* pt-deadlock-logger clear deadlocks child */"; PTDEBUG && _d($sql); open my $fh, '>', $sync_file or die "Error creating $sync_file: $OS_ERROR"; close $fh; PTDEBUG && _d('Clear deadlocks child ready (child)'); eval { $child_dbh->do($sql); }; # Should block against parent. PTDEBUG && _d($EVAL_ERROR); # Parent inserted value 0. $child_dbh->commit(); $child_dbh->disconnect(); exit; } elsif ( !defined($pid) ) { die "Failed to fork for --clear-deadlocks: " . ($OS_ERROR || ''); } # Wait up to 10s for the child to connect and become ready. for ( 1..40 ) { last if -f $sync_file; PTDEBUG && _d('Waiting for the clear deadlocks child'); sleep 0.25; } PTDEBUG && _d('Clear deadlocks child ready (parent)'); sleep 0.25; # wait for child to exec its SELECT statement # Make the child deadlock. $sql = "INSERT INTO $table (a) VALUES (0) " . "/* pt-deadlock-logger clear deadlocks parent */"; PTDEBUG && _d($sql); eval { $parent_dbh->do($sql); }; PTDEBUG && _d($EVAL_ERROR); # Reap the child. waitpid($pid, 0); # Drop the table. $sql = "DROP TABLE IF EXISTS $table"; PTDEBUG && _d($sql); $parent_dbh->do($sql); $parent_dbh->disconnect(); unlink $sync_file; return; } sub fingerprint { my ( $txns ) = @_; my $fingerprint = ''; foreach my $txn ( sort { $a->{thread} <=> $b->{thread} } values %$txns ) { $fingerprint = $fingerprint . join('', map { $txn->{$_} } qw(server ts thread) ); } PTDEBUG && _d('Deadlock fingerprint:', $fingerprint); return $fingerprint; } sub sig_int { my ( $signal ) = @_; $oktorun = 0; print STDERR "# Caught SIG$signal. Use 'kill -ABRT $PID' if " . "the tool does not exit normally in a few seconds.\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"; } # ############################################################################ # Run the program. # ############################################################################ if ( !caller ) { exit main(@ARGV); } 1; # Because this is a module as well as a script. # ############################################################################ # Documentation # ############################################################################ =pod =head1 NAME pt-deadlock-logger - Log MySQL deadlocks. =head1 SYNOPSIS Usage: pt-deadlock-logger [OPTIONS] DSN pt-deadlock-logger logs information about MySQL deadlocks on the given DSN. Information is printed to C, and it can also be saved to a table by specifying L<"--dest">. The tool runs for forever unless L<"--run-time"> or L<"--iterations"> is specified. Print deadlocks on host1: pt-deadlock-logger h=host1 Print deadlocks on host1 once then exit: pt-deadlock-logger h=host1 --iterations 1 Save deadlocks on host1 to percona_schema.deadlocks on host2: pt-deadlock-logger h=host1 --dest h=host2,D=percona_schema,t=deadlocks =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-deadlock-logger prints information about MySQL deadlocks by polling and parsing C. When a new deadlock occurs, it's printed to C and, if specified, saved to L<"--dest">. Only new deadlocks are printed. A fingerprint for each deadlock is created using the deadlock's server, ts, and thread values (even if these columns are not specified by L<"--columns">). A deadlock is printed if its fingerprint is different than the last deadlock's fingerprint. The L<"--dest"> statement uses C to eliminate duplicate deadlocks, so every deadlock is saved for every L<"--iterations">. =head1 OUTPUT New deadlocks are printed to C, unless L<"--quiet"> is specified. Errors and warnings are printed to C. See also L<"--columns"> and L<"--tab">. =head1 INNODB CAVEATS AND DETAILS InnoDB's output is hard to parse and sometimes there's no way to do it right. Sometimes not all information (for example, username or IP address) is included in the deadlock information. In this case there's nothing for the tool to put in those columns. It may also be the case that the deadlock output is so long (because there were a lot of locks) that the whole thing is truncated. Though there are usually two transactions involved in a deadlock, there are more locks than that; at a minimum, one more lock than transactions is necessary to create a cycle in the waits-for graph. pt-deadlock-logger prints the transactions (always two in the InnoDB output, even when there are more transactions in the waits-for graph than that) and fills in locks. It prefers waited-for over held when choosing lock information to output, but you can figure out the rest with a moment's thought. If you see one wait-for and one held lock, you're looking at the same lock, so of course you'd prefer to see both wait-for locks and get more information. If the two waited-for locks are not on the same table, more than two transactions were involved in the deadlock. Finally, keep in mind that, because usernames with spaces are not quoted by InnoDB, the tool will generally misreport the second word of these usernames as the hostname. =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 --clear-deadlocks type: string Use this table to create a small deadlock. This usually has the effect of clearing out a huge deadlock, which otherwise consumes the entire output of C. The table must not exist. pt-deadlock-logger will create it with the following structure: =for comment ignore-pt-internal-value MAGIC_clear_deadlocks CREATE TABLE percona_schema.clear_deadlocks ( a INT PRIMARY KEY ) ENGINE=InnoDB After creating the table and causing a small deadlock, the tool will drop the table again. =item --columns type: Array; default: server, ts, thread, txn_id, txn_time, user, hostname, ip, db, tbl, idx, lock_type, lock_mode, wait_hold, victim, query The columns are: =over =item server The (source) server on which the deadlock occurred. This might be useful if you're tracking deadlocks on many servers. =item ts The date and time of the last detected deadlock. =item thread The MySQL thread number, which is the same as the connection ID in SHOW FULL PROCESSLIST. =item txn_id The InnoDB transaction ID, which InnoDB expresses as two unsigned integers. I have multiplied them out to be one number. =item txn_time How long the transaction was active when the deadlock happened. =item user The connection's database username. =item hostname The connection's host. =item ip The connection's IP address. If you specify L<"--numeric-ip">, this is converted to an unsigned integer. =item db The database in which the deadlock occurred. =item tbl The table on which the deadlock occurred. =item idx The index on which the deadlock occurred. =item lock_type The lock type the transaction held on the lock that caused the deadlock. =item lock_mode The lock mode of the lock that caused the deadlock. =item wait_hold Whether the transaction was waiting for the lock or holding the lock. Usually you will see the two waited-for locks. =item victim Whether the transaction was selected as the deadlock victim and rolled back. =item query The query that caused the deadlock. =back =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-dest-table Create the table specified by L<"--dest">. Normally the L<"--dest"> table is expected to exist already. This option causes pt-deadlock-logger to create the table automatically using the suggested table structure. =item --daemonize Fork to the background and detach from the shell. POSIX operating systems only. =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 --dest type: DSN DSN for where to store deadlocks; specify at least a database (D) and table (t). Missing values are filled in with the same values from the source host, so you can usually omit most parts of this argument if you're storing deadlocks on the same server on which they happen. The following table structure is suggested if you want to store all the information pt-deadlock-logger can extract about deadlocks: =for comment ignore-pt-internal-value MAGIC_dest_table CREATE TABLE deadlocks ( server char(20) NOT NULL, ts timestamp NOT NULL DEFAULT CURRENT_TIMESTAMP, thread int unsigned NOT NULL, txn_id bigint unsigned NOT NULL, txn_time smallint unsigned NOT NULL, user char(16) NOT NULL, hostname char(20) NOT NULL, ip char(15) NOT NULL, -- alternatively, ip int unsigned NOT NULL db char(64) NOT NULL, tbl char(64) NOT NULL, idx char(64) NOT NULL, lock_type char(16) NOT NULL, lock_mode char(1) NOT NULL, wait_hold char(1) NOT NULL, victim tinyint unsigned NOT NULL, query text NOT NULL, PRIMARY KEY (server,ts,thread) ) ENGINE=InnoDB If you use L<"--columns">, you can omit whichever columns you don't want to store. =item --help Show help and exit. =item --host short form: -h; type: string Connect to host. =item --interval type: time; default: 30 How often to check for deadlocks. If no L<"--run-time"> is specified, pt-deadlock-logger runs forever, checking for deadlocks at every interval. See also L<"--run-time">. =item --iterations type: int How many times to check for deadlocks. By default, this option is undefined which means an infinite number of iterations. The tool always exits for L<"--run-time">, regardless of the value specified for this option. For example, the tool will exit after 1 minute with C<--run-time 1m --iterations 4 --interval 30> because 4 iterations at 30 second intervals would take 2 minutes, longer than the 1 mintue run-time. =item --log type: string Print all output to this file when daemonized. =item --numeric-ip Express IP addresses as integers. =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 Do not deadlocks; only print errors and warnings to C. =item --run-time type: time How long to run before exiting. By default pt-deadlock-logger runs forever, checking for deadlocks every L<"--interval"> seconds. =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 --tab Use tabs to separate columns instead of spaces. =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. =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 * t Table in which to store deadlock information. =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-deadlock-logger ... > 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 to download the latest release of Percona Toolkit. Or, get the latest release from the command line: wget percona.com/get/percona-toolkit.tar.gz wget percona.com/get/percona-toolkit.rpm wget percona.com/get/percona-toolkit.deb You can also get individual tools from the latest release: wget percona.com/get/TOOL Replace C 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 to learn about other free, open-source software from Percona. =head1 COPYRIGHT, LICENSE, AND WARRANTY This program is copyright 2011-2016 Percona LLC and/or its affiliates, 2007-2011 Baron Schwartz. 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 pt-deadlock-logger 2.2.20 =cut percona-toolkit-2.2.20/MANIFEST0000664000175000017500000000124413021632517015731 0ustar vagrantvagrantChangelog CONTRIBUTE.md 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