DBIx-Connector-0.60/000755 000765 000024 00000000000 14705312553 013725 5ustar00apstaff000000 000000 DBIx-Connector-0.60/inc/000755 000765 000024 00000000000 14705312553 014476 5ustar00apstaff000000 000000 DBIx-Connector-0.60/LICENSE000644 000765 000024 00000043670 14705312553 014744 0ustar00apstaff000000 000000 This software is copyright (c) 2016 by David E. Wheeler. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2016 by David E. Wheeler. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, 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 license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our 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. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, 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 a 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 tell them 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. 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 Agreement 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 work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 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 General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual 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 General Public License. d) 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. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 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 Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying 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. 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. 7. 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 the 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 the license, you may choose any version ever published by the Free Software Foundation. 8. 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 9. 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. 10. 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 Appendix: 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 humanity, 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) 19yy 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 1, 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) 19xx 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 a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2016 by David E. Wheeler. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End DBIx-Connector-0.60/Changes000644 000765 000024 00000034533 14705312311 015220 0ustar00apstaff000000 000000 Release history for DBIx-Connector 0.60 Mon 21 Oct 2024 - MariaDB support (Issue #50) - Fix for leaking $@ from driver constructor (Issue #51) - Fix for swallowing driver compile errors 0.59 Sun 02 Jul 2023 - Fix for Windows t/load.t failures 0.58 Mon 29 Aug 2022 - No functional changes - Updated packaging and package metadata 0.57 Mon 27 Sep 2021 - `$conn->dsn` and `$conn->driver_name` accessors - Use of ExtUtils::MakeMaker instead of Module::Build - Corrected, reduced, properly declared prerequisites - POD tests in `xt/` - Simplified SQLite version check - Doc typo fix. Thanks to Michael R. Davis 0.56 Wed 16 Mar 2016 - Added Firebird support, thanks to Stefan Suciu. - Fixed SQLite savepoint support to properly detect SQlite versions 3.9 and higher. - Restored MySQL savepoint testing when the DBICTEST_* environment variables are set. 0.55 Fri 05 Feb 2016 - Added versions to the RollbackError exception classes to make PAUSE happy. 0.54 Fri 05 Feb 2016 - Removeed the Pod tests from the distribution. - Fixed the example code for handling `rollback_error` exceptions in the documentation to properly wrap the transaction in an exception handler. Patch from Perlover (issue #32). - Improved handling of connection failures when RaiseError (or HandleError) is not set. Thanks to Andreas Huber for the report and fix. - Document that `$_` is set locally, not globally, in the methods that set it. Suggested by William Lindley. - The disconnect method no longer longer remove entries from the DBI handle's CachedKids attribute. That behavior appears to be a workaround for a database we don't (yet) support. - Fixed a test failure where the test system has the `$DBI_DSN` or `$DBI_DRIVER` environment variable set. Thanks to Erik Rijkers for the patch. - Added recommendation to use DBD::Pg 3.5.0 or later to the Pg driver. Earlier versions had an incorrect implementation of the `ping()` method (Issue #41). 0.53 Wed 20 Mar 2013 - Fixed some documentation typos, thanks to Mike O'Regan (Issue #22). - Fixed issue where an connection failure caused an unhelpful error (Issue #26). 0.52 Tue 29 May 2012 - The DBI params are now encapsulated in a code reference, rather than stored as the passed array, so that the password is less likely to be displayed in a dump. Idea borrowed from Rose::DB. Patch from Brad Bowman. - Eliminated warning about the non-portability of a v-string on older Perls. Thanks to Mark Lawrence for the report (Issue #17). - Removed a couple of leftover examples of the `catch` feature removed in v0.50. Thanks to Randy Stauner for the patch! - Eliminated more "Use of qw(...) as parentheses" syntax errors in tests when running on Perl 5.17. - Add mention of DBI Callbacks parameter to the docs, as folks often ask for this functionality, not realizing that the DBI already provides it. Randy Stauner. 0.51 Sat 18 Feb 2012 - Fixed internal exception handling on Perls less than 5.14, where some exceptions woult not be propagated to the caller. 0.50 Tue 14 Feb 2012 - The `catch` functionality has been completely removed. Any `catch` block passed to `run()`, `txn()`, or `svp()` will be ignored. Errors will trigger fatal exceptions. - Removed the `with` method, which was deprecated in 0.34. Use `mode()` instead. - Fixed bad method call attempted when an `svp()` block failed. Thanks to Ricardo SIGNES for the regression test and the fix. - Fixed creation of the SQLite driver savepoint methods so that they exist and work even if the driver is loaded before DBD::SQLite. Thanks to Ricardo SIGNES for the regression test and the fix. 0.47 Mon 26 Sep 2011 - Use of the deprecated `catch` functionality now warns on every call, rather than just the first call from a given caller. 0.46 Sun 17 Jul 2011 - Eliminated "Use of qw(...) as parentheses is deprecated" warning in test when running on Perl 5.14. - Properly `local`ing `$$` in the `t/base.t` test so that it doesn't die on Perl 5.15. Thanks to Andreas J. Koenig for the report and diagnosis and to Nicholas Clark for the fix. - Duplicate paragraphs removed from `README.md` thanks to Ask Bjørn Hansen. - The `catch` functionality is deprecated. It will warn once for each caller to keep log verbosity down. In the next release, it will warn for every call. The release after that, it will be removed altogether. 0.45 Tue 10 May 2011 - Fixed crash when `in_txn()` was called before an actual connection was established. - Strongly recommend setting `AutoCommit` to true in the documentation. Setting `AutoCommit` to false defeats the scoping behavior of `txn()` and therefore should not be used. - Nested exception handling now works properly in nested calls to `run()` in fixup mode and in nested calls to `txn()` in all modes. Thanks to Mark Lawrence for the report (RT #66974). 0.44 Sun 20 Mar 2011 - Fixed bug with the MySQL driver introduced by the auto-reconnection fix in 0.43. Sorry for the lame mistake. [Lee Aylward] 0.43 Thu 17 Mar 2011 - DBIx::Connector now sets the DBI `RaiseError` parameter to true in `new()` if neither it nor `HandleError` has been specified. This is to increase the likelihood that exception handling will be properly triggered in `run()`, `txn()`, and `svp()`. Documentation has also been added to emphasize the importance of setting `RaiseError` or `HandleError` appropriately. - Documented that `AutoInactiveDestroy` is set to true in `new()` if it is not specified. It's important tht this attribute be true in forking environments. - After connecting to the database, the MySQL driver, DBIx::Connector::Driver::mysql, now always sets the `mysql_auto_reconnect` attribute to false. This is to prevent MySQL's auto-reconnection feature from interfering with DBIx::Connector's auto-reconnection functionality in `fixup` mode. Thanks to Karen Etheridge and Peter Rabbitson for the report. - Removed mention of the use of the `catch` function from Try::Tiny, since it is no longer compatible to use passing the exception-handling function. Just using `catch =>` instead, which is cleaner-looking anyway (RT #65196). 0.42 Fri 17 Dec 2010 - If a catch block died, the exception was not being propagated. That is, if a catch block threw an exception, DBIx::Connector ate it, and any calling code would not be able to catch it. This was a pretty serious bug; upgrading is strongly recommended for anyone using catch blocks. - When `run()`, `txn()`, or `svp()` was called recursively from within a second fixup execution, it was not respecting the fact that it was recursive and could try to start a transaction again. This happened *only* when a fixup run found that the database was disconnected and successfully re-connected, so it's a pretty rare condition. 0.41 Wed 08 Dec 2010 - `connect()` no longer returns a disconnected database handle. Thanks to John Siracusa for the spot (Issue #6). - Added `disconnect_on_destroy()`, which can be used to disable disconnecting the database handle when the connector object is destroyed. Suggested by John Siracusa. 0.40 Fri 17 Sep 2010 - The code refs passed to `run()`, `txn()`, and `svp()` now know their contexts, so that `wantarray` can be used to decide what to return. Patch from Yaroslav Korshak. - Set `AutoInactiveDestroy` on connect with DBI 1.614 and higher, unless it is explicitly set in the attributes. This makes things even safer in a forking environment, preventing a parent process from getting disconnected when a child exits without using the connection. The reports from Peter Rabbitson and Aran Deltac and subsequent discussion with Tim Bunce led to the addition of this attribute in DBI 1.614, which is now the recommended version of DBI. - `DESTROY()` no longer pings the database or rolls back transactions. It now simply calls `disconnect`. This avoids warnings during global destruction, and doesn't seem necessary anyway, as the DBI does these things during global destruction (and always has). Thanks to Matt Trout for the heads-up. - `DESTROY()` now clears `CachedKids`, following the precedent of DBIx::Class. May not be needed for recent-ish drivers, but seems harmless and it's nice to avoid warnings were possible. Reported by Matt Trout. - The `connected()` method no longer `local`ly sets `RaiseError`. It instead leaves that to the drivers (currenly only Driver::Oracle). - The exception classes `DBIx::Connector::TxnRollbackError` and `DBIx::Connector::SvpRollbackError` now use `our @ISA =` instead of `use base` to inherit from `DBIx::Connector::RollbackError. This is to avoid failures from mod_perl restarts. Suggested by Matt Trout. - Require Test::Pod 1.41 for POD tests so that `L` is considered valid. 0.35 Fri 04 Jun 2010 - Added a scoping block around the execution of the blocks passed to `run()`, `txn()`, and `svp()`. This prevents an app from exiting when a user returns from the block via the `next` or `last` keyword, which in turn prevented transaction management code from running. Thanks to Aran Deltac for the suggestion. - Added exception object for rollback failures. This is to keep rollback failures from completely swallowing up the underlying transaction failures. 0.34 Mon 03 May 2010 - Added `mode()` attribute to control the default mode used by `run()`, `txn()`, and `svp()`. - Deprecated `with()`. Its use triggers a warning and it will be removed in a future version. Use `mode()` instead. 0.33 Wed 31 Mar 2010 - A few useful documentation improvements, thanks to Quinn Weaver. - Added `in_txn()`, which returns true when the connection is in a transaction and false when it's not. 0.32 Mon 22 Feb 2010 - Switched to using `FETCH()` and `STORE()` to get and set DBI attributes where possible. The primary reason is to avoid death during global destruction, when the DBI's `tie`d interface can sometimes be pulled out from under us. Switched to the OO interface througout to be consistent. 0.31 Mon 09 Nov 2009 - Added missing version numbers to DBIx::Connector::Driver::SQLite and the proxy class used by `with()`. - Fixed orphaned references to DBIx::Connection to properly be DBIx::Connector. - Removed methods deprecated in 0.20: `do()`, `txn_do()`, `svp_do()`, and `clear_cache()`. - Some refactoring and code cleanup. - Some doc typos corrected by Robert Buels. - Fixed test failure on Win32. 0.30 Thu 29 Oct 2009 - Compatibility change: Additional arguments to `run()`, `txn()`, and `svp()` are no longer passed on to the execution of the block, since they are immediately available to the closure, anyway. This simplifies things for integrated exception handling (next item). - Added integrated exception-handling support to `run()`, `txn()`, and `svp()`. Thanks to Mark Lawrence for the suggestion. - Removed the undocumented `savepoint()`, `release()`, and `rollback_to()` methods from DBIx::Connector, since those methods are in the drivers, and so were redundant. - Fixed the `author` section of `META.yml`. - `svp()` no longer throws an exception whe used with an RDBMS that doesn't support savepoints. In such situations, savepoints are treated as a no-op, and thus the transactional behavior of `svp()` becomes the same as `txn()`. - Moved up the discussion of calling `svp()` outside of a transaction in the documentation. 0.20 Tue 20 Oct 2009 - Compatibility changes: + Added `run()`, `txn()`, and `svp()` as replacements for `do()`, `txn_do()`, and `svp_do()`. The latter will issue a warning when called, and be removed in two releases. + Eliminated caching and mod_perl special-casing. - Fixed the GitHub links for realz. - Updated minimum required Test::More to 0.88 so that testing classes with `isa_ok()` will work as expected. Thanks to mlawren for the spot. - Fixed bug passing arguments on retry in `txn()`. Thanks to [Mark Lawrence](http://github.com/mlawren) for the pull request. - Fixed a bug in `txn()` where it would fail to notify other blocks that it was running the block when the user started a transaction. - Changed `dbh()` so that it does not call `ping()` when it is called from within a code reference passed to a `run*()` method. - Made the docs with regard to the re-execution of a code reference passed to `run()` and friends in fixup mode more accurate, thanks to Tim Bunce. - Fetching a cached database handle now always checks its `Active` attribute as well as different process and thread IDs. The only thing not always done is `ping`ing the database. - Added `with()`. 0.12 Tue 06 Oct 2009 - Fixed the GitHub links, which were still using the old name. - Removed `use feature` and `use utf8` from `t/pod-coverage.t` -- those were pastos from another project. - Removed `use DBD::SQLite` from DBix::Connector::Driver::SQLite. It will already have been loaded by the time that code loads. 0.11 Mon 05 Oct 2009 - Filled in the important details in the README. - Changed name from DBIx::Connection to DBIx::Connector, as there is already a module called DBIx::Connection on the CPAN. 0.10 Mon 05 Oct 2009 - Initial version, with code borrowed from DBIx::Class, Apache::DBI, Catalyst::Model::DBI, and various other locales. DBIx-Connector-0.60/MANIFEST000644 000765 000024 00000001377 14705312553 015066 0ustar00apstaff000000 000000 Changes Makefile.PL inc/WriteMakefile.pl inc/boilerplate.pl lib/DBIx/Connector.pm lib/DBIx/Connector/Driver.pm lib/DBIx/Connector/Driver/Firebird.pm lib/DBIx/Connector/Driver/MSSQL.pm lib/DBIx/Connector/Driver/MariaDB.pm lib/DBIx/Connector/Driver/Oracle.pm lib/DBIx/Connector/Driver/Pg.pm lib/DBIx/Connector/Driver/SQLite.pm lib/DBIx/Connector/Driver/mysql.pm t/00-load.t t/base.t t/driver.t t/lib/Hook/Guard.pm t/run.t t/run_fixup.t t/run_ping.t t/svp.t t/svp_fixup.t t/svp_live.t t/svp_ping.t t/txn.t t/txn_fixup.t t/txn_ping.t xt/pod-coverage.t xt/pod-spelling.t xt/pod.t MANIFEST META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) LICENSE README DBIx-Connector-0.60/t/000755 000765 000024 00000000000 14705312553 014170 5ustar00apstaff000000 000000 DBIx-Connector-0.60/xt/000755 000765 000024 00000000000 14705312553 014360 5ustar00apstaff000000 000000 DBIx-Connector-0.60/README000644 000765 000024 00000006027 14705312553 014612 0ustar00apstaff000000 000000 DBIx::Connector DBIx::Connector provides a simple interface for fast and safe DBI connection and transaction management. Connecting to a database can be expensive; you don't want your application to re-connect every time you need to run a query. The efficient thing to do is to hang on to a database handle to maintain a connection to the database in order to minimize that overhead. DBIx::Connector lets you do that without having to worry about dropped or corrupted connections. You might be familiar with Apache::DBI and with the DBI's "connect_cached()" constructor. DBIx::Connector serves a similar need, but does a much better job. How is it different? I'm glad you asked! * Fork Safety Like Apache::DBI, but unlike "connect_cached()", DBIx::Connector create a new database connection if a new process has been "fork"ed. This happens all the time under mod_perl, in POE applications, and elsewhere. Works best with DBI 1.614 and higher. * Thread Safety Unlike Apache::DBI or "connect_cached()", DBIx::Connector will create a new database connection if a new thread has been spawned. As with "fork"ing, spawning a new thread can break database connections. * Works Anywhere Unlike Apache::DBI, DBIx::Connector runs anywhere -- inside of mod_perl or not. Why limit yourself? * Explicit Interface DBIx::Connector has an explicit interface. There is none of the magical action-at-a-distance crap that Apache::DBI is guilty of, and no global caching. I've personally diagnosed a few issues with Apache::DBI's magic, and killed it off in two different projects in favor of "connect_cached()", only to be tripped up by other gotchas. No more. * Optimistic Execution If you use "run()" and "txn()", the database handle will be passed without first pinging the server. For the 99% or more of the time when the database is just there, you'll save a ton of overhead without the ping. DBIx::Connector's other feature is transaction management. Borrowing an interface from DBIx::Class, DBIx::Connector offers an API that efficiently handles the scoping of database transactions so that you needn't worry about managing the transaction yourself. Even better, it offers an API for savepoints if your database supports them. Within a transaction, you can scope savepoints to behave like subtransactions, so that you can save some of your work in a transaction even if part of it fails. See "txn()" and "svp()" for the goods. INSTALLATION This is a Perl module distribution. It should be installed with whichever tool you use to manage your installation of Perl, e.g. any of cpanm . cpan . cpanp -i . Consult http://www.cpan.org/modules/INSTALL.html for further instruction. Should you wish to install this module manually, the procedure is perl Makefile.PL make make test make install COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. DBIx-Connector-0.60/META.yml000644 000765 000024 00000001406 14705312553 015177 0ustar00apstaff000000 000000 --- abstract: 'Fast, safe DBI connection and transaction management' author: - 'David E. Wheeler' build_requires: Test::More: '0' dynamic_config: 0 generated_by: 'ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBIx-Connector no_index: directory: - t - inc recommends: DBI: '1.614' requires: DBI: '1.605' perl: '5.008001' resources: bugtracker: https://github.com/ap/DBIx-Connector/issues license: https://dev.perl.org/licenses/ repository: https://github.com/ap/DBIx-Connector.git version: '0.60' x_copyright: holder: 'David E. Wheeler' year: 2016 x_serialization_backend: 'CPAN::Meta::YAML version 0.018' DBIx-Connector-0.60/lib/000755 000765 000024 00000000000 14705312553 014473 5ustar00apstaff000000 000000 DBIx-Connector-0.60/Makefile.PL000644 000765 000024 00000001366 14701027467 015710 0ustar00apstaff000000 000000 use 5.008001; use strict; use warnings; my $sc = q; my $bt = q; our %META = ( name => 'DBIx-Connector', author => 'David E. Wheeler', x_copyright => { holder => 'David E. Wheeler', year => 2016 }, license => 'perl_5', resources => { license => [ q ], repository => { type => 'git', url => "$sc.git", web => $sc }, bugtracker => { web => $bt }, }, dynamic_config => 0, prereqs => { runtime => { requires => {qw( perl 5.008001 DBI 1.605 )}, recommends => {qw( DBI 1.614 )}, }, test => { requires => {qw( Test::More 0 )}, }, }, ); require './inc/WriteMakefile.pl'; DBIx-Connector-0.60/META.json000644 000765 000024 00000002604 14705312553 015350 0ustar00apstaff000000 000000 { "abstract" : "Fast, safe DBI connection and transaction management", "author" : [ "David E. Wheeler" ], "dynamic_config" : 0, "generated_by" : "ExtUtils::MakeMaker version 7.34, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "DBIx-Connector", "no_index" : { "directory" : [ "t", "inc" ] }, "prereqs" : { "build" : {}, "configure" : {}, "runtime" : { "recommends" : { "DBI" : "1.614" }, "requires" : { "DBI" : "1.605", "perl" : "5.008001" } }, "test" : { "requires" : { "Test::More" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/ap/DBIx-Connector/issues" }, "license" : [ "https://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "https://github.com/ap/DBIx-Connector.git", "web" : "https://github.com/ap/DBIx-Connector" } }, "version" : "0.60", "x_copyright" : { "holder" : "David E. Wheeler", "year" : 2016 }, "x_serialization_backend" : "JSON::PP version 4.02" } DBIx-Connector-0.60/lib/DBIx/000755 000765 000024 00000000000 14705312553 015261 5ustar00apstaff000000 000000 DBIx-Connector-0.60/lib/DBIx/Connector.pm000644 000765 000024 00000076030 14705311713 017554 0ustar00apstaff000000 000000 use 5.008001; use strict; use warnings; package DBIx::Connector; use DBI '1.605'; use DBIx::Connector::Driver; our $VERSION = '0.60'; sub new { my $class = shift; my @args = @_; bless { _args => sub { @args }, _svp_depth => 0, _mode => 'no_ping', _dond => 1, } => $class; } sub DESTROY { $_[0]->disconnect if $_[0]->{_dond} } sub _connect { my $self = shift; my @args = $self->{_args}->(); my $dbh = do { if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) { local $DBI::connect_via = 'connect'; # Disable Apache::DBI. DBI->connect( @args ); } else { DBI->connect( @args ); } } or return undef; # Modify default values. $dbh->STORE(AutoInactiveDestroy => 1) if DBI->VERSION > 1.613 && ( @args < 4 || !exists $args[3]->{AutoInactiveDestroy} ); $dbh->STORE(RaiseError => 1) if @args < 4 || ( !exists $args[3]->{RaiseError} && !exists $args[3]->{HandleError} ); # Where are we? $self->{_pid} = $$; $self->{_tid} = threads->tid if $INC{'threads.pm'}; $self->{_dbh} = $dbh; $self->{driver_name} ||= $dbh->{Driver}{Name}; # Set up the driver and go! return $self->driver->_connect($dbh, @args); } sub dsn { ( $_[0]{_args}->() )[0] } sub driver_name { my $self = shift; $self->{driver_name} ||= ( DBI->parse_dsn( $self->dsn ) )[1]; } sub driver { my $self = shift; $self->{driver} ||= DBIx::Connector::Driver->new( $self->{driver_name} || $self->driver_name ); } sub connect { my $self = shift->new(@_); $self->{_dond} = 0; $self->dbh; } sub dbh { my $self = shift; my $dbh = $self->_seems_connected or return $self->_connect; return $dbh if $self->{_in_run}; return $self->connected ? $dbh : $self->_connect; } # Just like dbh(), except it doesn't ping the server. sub _dbh { my $self = shift; $self->_seems_connected || $self->_connect; } sub connected { my $self = shift; return unless $self->_seems_connected; my $dbh = $self->{_dbh} or return; return $self->driver->ping($dbh); } sub mode { my $self = shift; return $self->{_mode} unless @_; require Carp && Carp::croak(qq{Invalid mode: "$_[0]"}) unless $_[0] =~ /^(?:fixup|(?:no_)?ping)$/; $self->{_mode} = shift; } sub disconnect_on_destroy { my $self = shift; return $self->{_dond} unless @_; $self->{_dond} = !!shift; } sub in_txn { my $dbh = shift->{_dbh} or return; return !$dbh->FETCH('AutoCommit'); } # returns true if there is a database handle and the PID and TID have not # changed and the handle's Active attribute is true. sub _seems_connected { my $self = shift; my $dbh = $self->{_dbh} or return; if ( defined $self->{_tid} && $self->{_tid} != threads->tid ) { return; } elsif ( $self->{_pid} != $$ ) { # We've forked, so prevent the parent process handle from touching the # DB on DESTROY. Here in the child process, that could really screw # things up. This is superfluous when AutoInactiveDestroy is set, but # harmless. It's better to be proactive anyway. $dbh->STORE(InactiveDestroy => 1); return; } # Use FETCH() to avoid death when called from during global destruction. return $dbh->FETCH('Active') ? $dbh : undef; } sub disconnect { my $self = shift; if (my $dbh = $self->{_dbh}) { # Some databases need this to stop spewing warnings, according to # DBIx::Class::Storage::DBI. Probably Sybase, as the code was added # when Sybase ASA and SQLAnywhere support were added to DBIx::Class. # If that ever becomes an issue for us, add a _disconnect to the # Driver class that does it, don't do it here. # $dbh->STORE(CachedKids => {}); $dbh->disconnect; $self->{_dbh} = undef; } return $self; } sub run { my $self = shift; my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift; local $self->{_mode} = $mode; return $self->_fixup_run(@_) if $mode eq 'fixup'; return $self->_run(@_); } sub _run { my ($self, $code) = @_; my $dbh = $self->{_mode} eq 'ping' ? $self->dbh : $self->_dbh; local $self->{_in_run} = 1; return _exec( $dbh, $code, wantarray ); } sub _fixup_run { my ($self, $code) = @_; my $dbh = $self->_dbh; my $wantarray = wantarray; return _exec( $dbh, $code, $wantarray ) if $self->{_in_run} || !$dbh->FETCH('AutoCommit'); local $self->{_in_run} = 1; my ($err, @ret); TRY: { local $@; @ret = eval { _exec( $dbh, $code, $wantarray ) }; $err = $@; } if ($err) { die $err if $self->connected; # Not connected. Try again. return _exec( $self->_connect, $code, $wantarray, @_ ); } return $wantarray ? @ret : $ret[0]; } sub txn { my $self = shift; my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift; local $self->{_mode} = $mode; return $self->_txn_fixup_run(@_) if $mode eq 'fixup'; return $self->_txn_run(@_); } sub _txn_run { my ($self, $code) = @_; my $driver = $self->driver; my $wantarray = wantarray; my $dbh = $self->{_mode} eq 'ping' ? $self->dbh : $self->_dbh; unless ($dbh->FETCH('AutoCommit')) { local $self->{_in_run} = 1; return _exec( $dbh, $code, $wantarray ); } my ($err, @ret); TRY: { local $@; eval { local $self->{_in_run} = 1; $driver->begin_work($dbh); @ret = _exec( $dbh, $code, $wantarray ); $driver->commit($dbh); }; $err = $@; } if ($err) { $err = $driver->_rollback($dbh, $err); die $err; } return $wantarray ? @ret : $ret[0]; } sub _txn_fixup_run { my ($self, $code) = @_; my $dbh = $self->_dbh; my $driver = $self->driver; my $wantarray = wantarray; local $self->{_in_run} = 1; return _exec( $dbh, $code, $wantarray ) unless $dbh->FETCH('AutoCommit'); my ($err, @ret); TRY: { local $@; eval { $driver->begin_work($dbh); @ret = _exec( $dbh, $code, $wantarray ); $driver->commit($dbh); }; $err = $@; } if ($err) { if ($self->connected) { $err = $driver->_rollback($dbh, $err); die $err; } # Not connected. Try again. $dbh = $self->_connect; TRY: { local $@; eval { $driver->begin_work($dbh); @ret = _exec( $dbh, $code, $wantarray ); $driver->commit($dbh); }; $err = $@; } if ($err) { $err = $driver->_rollback($dbh, $err); die $err; } } return $wantarray ? @ret : $ret[0]; } sub svp { my $self = shift; my $dbh = $self->{_dbh}; # Gotta have a transaction. return $self->txn( @_ ) if !$dbh || $dbh->FETCH('AutoCommit'); my $mode = ref $_[0] eq 'CODE' ? $self->{_mode} : shift; local $self->{_mode} = $mode; my $code = shift; my ($err, @ret); my $wantarray = wantarray; my $driver = $self->driver; my $name = "savepoint_$self->{_svp_depth}"; ++$self->{_svp_depth}; TRY: { local $@; eval { $driver->savepoint($dbh, $name); @ret = _exec( $dbh, $code, $wantarray ); $driver->release($dbh, $name); }; $err = $@; } --$self->{_svp_depth}; if ($err) { # If we died, there is nothing to be done. if ($self->connected) { $err = $driver->_rollback_and_release($dbh, $name, $err); } die $err; } return $wantarray ? @ret : $ret[0]; } sub _exec { my ($dbh, $code, $wantarray) = @_; local $_ = $dbh or return; # Block prevents exiting via next or last, otherwise no commit/rollback. NOEXIT: { return $wantarray ? $code->($dbh) : scalar $code->($dbh) if defined $wantarray; return $code->($dbh); } return; } 1; __END__ =head1 NAME DBIx::Connector - Fast, safe DBI connection and transaction management =head1 SYNOPSIS use DBIx::Connector; # Create a connection. my $conn = DBIx::Connector->new($dsn, $username, $password, { RaiseError => 1, AutoCommit => 1, }); # Get the database handle and do something with it. my $dbh = $conn->dbh; $dbh->do('INSERT INTO foo (name) VALUES (?)', undef, 'Fred' ); # Do something with the handle more efficiently. $conn->run(fixup => sub { $_->do('INSERT INTO foo (name) VALUES (?)', undef, 'Fred' ); }); =head1 DESCRIPTION DBIx::Connector provides a simple interface for fast and safe DBI connection and transaction management. Connecting to a database can be expensive; you don't want your application to re-connect every time you need to run a query. The efficient thing to do is to hang on to a database handle to maintain a connection to the database in order to minimize that overhead. DBIx::Connector lets you do that without having to worry about dropped or corrupted connections. You might be familiar with L and with the L's L|DBI/connect_cached> constructor. DBIx::Connector serves a similar need, but does a much better job. How is it different? I'm glad you asked! =over =item * Fork Safety Like Apache::DBI, but unlike C, DBIx::Connector create a new database connection if a new process has been Ced. This happens all the time under L, in L applications, and elsewhere. Works best with DBI 1.614 and higher. =item * Thread Safety Unlike Apache::DBI or C, DBIx::Connector will create a new database connection if a new thread has been spawned. As with Cing, spawning a new thread can break database connections. =item * Works Anywhere Unlike Apache::DBI, DBIx::Connector runs anywhere -- inside of mod_perl or not. Why limit yourself? =item * Explicit Interface DBIx::Connector has an explicit interface. There is none of the magical action-at-a-distance crap that Apache::DBI is guilty of, and no global caching. I've personally diagnosed a few issues with Apache::DBI's magic, and killed it off in two different projects in favor of C, only to be tripped up by other gotchas. No more. =item * Optimistic Execution If you use C and C, the database handle will be passed without first pinging the server. For the 99% or more of the time when the database is just there, you'll save a ton of overhead without the ping. =back DBIx::Connector's other feature is transaction management. Borrowing an interface from L, DBIx::Connector offers an API that efficiently handles the scoping of database transactions so that you needn't worry about managing the transaction yourself. Even better, it offers an API for savepoints if your database supports them. Within a transaction, you can scope savepoints to behave like subtransactions, so that you can save some of your work in a transaction even if part of it fails. See L|/"txn"> and L|/"svp"> for the goods. =head1 USAGE Unlike L and L|DBI/connect_cached>, DBIx::Connector doesn't cache database handles. Rather, for a given connection, it makes sure that the connection is just there whenever you want it, to the extent possible. The upshot is that it's safe to create a connection and then keep it around for as long as you need it, like so: my $conn = DBIx::Connector->new(@args); You can store the connection somewhere in your app where you can easily access it, and for as long as it remains in scope, it will try its hardest to maintain a database connection. Even across Cs (especially with DBI 1.614 and higher) and new threads, and even calls to C<< $conn->dbh->disconnect >>. When you don't need it anymore, let it go out of scope and the database connection will be closed. The upshot is that your code is responsible for hanging onto a connection for as long as it needs it. There is no magical connection caching like in L and L|DBI/connect_cached>. =head2 Execution Methods The real utility of DBIx::Connector comes from the use of the execution methods, L|/"run">, L|/"txn">, or L|/"svp">. Instead of this: $conn->dbh->do($query); Try this: $conn->run(sub { $_->do($query) }); # returns retval from the sub {...} The difference is that the C optimistically assumes that an existing database handle is connected and executes the code reference without pinging the database. The vast majority of the time, the connection will of course still be open. You therefore save the overhead of a ping query every time you use C (or C). Of course, if a block passed to C dies because the DBI isn't actually connected to the database you'd need to catch that failure and try again. DBIx::Connector provides a way to overcome this issue: connection modes. =head3 Connection Modes When calling L|/"run">, L|/"txn">, or L|/"svp">, each executes within the context of a "connection mode." The supported modes are: =over =item * C =item * C =item * C =back Use them via an optional first argument, like so: $conn->run(ping => sub { $_->do($query) }); Or set up a default mode via the C accessor: $conn->mode('fixup'); $conn->run(sub { $_->do($query) }); The return value of the block will be returned from the method call in scalar or array context as appropriate, and the block can use C to determine the context. Returning the value makes them handy for things like constructing a statement handle: my $sth = $conn->run(fixup => sub { my $sth = $_->prepare('SELECT isbn, title, rating FROM books'); $sth->execute; $sth; }); In C mode, C will ping the database I running the block. This is similar to what L and the L's L|DBI/connect_cached> method do to check the database connection, and is the safest way to do so. If the ping fails, DBIx::Connector will attempt to reconnect to the database before executing the block. However, C mode does impose the overhead of the C every time you use it. In C mode, DBIx::Connector executes the block without pinging the database. But in the event the block throws an exception, if DBIx::Connector finds that the database handle is no longer connected, it will reconnect to the database and re-execute the block. Therefore, the code reference should have B as double-execution in the event of a stale database connection could break something: my $count; $conn->run(fixup => sub { $count++ }); say $count; # may be 1 or 2 C is the most efficient connection mode. If you're confident that the block will have no deleterious side-effects if run twice, this is the best option to choose. If you decide that your block is likely to have too many side-effects to execute more than once, you can simply switch to C mode. The default is C, but you likely won't ever use it directly, and isn't recommended in any event. Simple, huh? Better still, go for the transaction management in L|/"txn"> and the savepoint management in L|/"svp">. You won't be sorry, I promise. =head3 Rollback Exceptions In the event of a rollback in L|/"txn"> or L|/"svp">, if the rollback itself fails, a DBIx::Connector::TxnRollbackError or DBIx::Connector::SvpRollbackError exception will be thrown, as appropriate. These classes, which inherit from DBIx::Connector::RollbackError, stringify to display both the rollback error and the transaction or savepoint error that led to the rollback, something like this: Transaction aborted: No such table "foo" at foo.pl line 206. Transaction rollback failed: Invalid transaction ID at foo.pl line 203. For finer-grained exception handling, you can access the individual errors via accessors: =over =item C The transaction or savepoint error. =item C The rollback error. =back For example: use Try::Tiny; try { $conn->txn(sub { # ... }); } catch { if (eval { $_->isa('DBIx::Connector::RollbackError') }) { say STDERR 'Transaction aborted: ', $_->error; say STDERR 'Rollback failed too: ', $_->rollback_error; } else { warn "Caught exception: $_"; } }; If a L|/"svp"> rollback fails and its surrounding L|/"txn"> rollback I fails, the thrown DBIx::Connetor::TxnRollbackError exception object will have the savepoint rollback exception, which will be an DBIx::Connetor::SvpRollbackError exception object in its C attribute: use Try::Tiny; $conn->txn(sub { try { $conn->svp(sub { # ... }); } catch { if (eval { $_->isa('DBIx::Connector::RollbackError') }) { if (eval { $_->error->isa('DBIx::Connector::SvpRollbackError') }) { say STDERR 'Savepoint aborted: ', $_->error->error; say STDERR 'Its rollback failed too: ', $_->error->rollback_error; } else { say STDERR 'Transaction aborted: ', $_->error; } say STDERR 'Transaction rollback failed too: ', $_->rollback_error; } else { warn "Caught exception: $_"; } }; }); But most of the time, you should be fine with the stringified form of the exception, which will look something like this: Transaction aborted: Savepoint aborted: No such table "bar" at foo.pl line 190. Savepoint rollback failed: Invalid savepoint name at foo.pl line 161. Transaction rollback failed: Invalid transaction identifier at fool.pl line 184. This allows you to see you original SQL error, as well as the errors for the savepoint rollback and transaction rollback failures. =head1 INTERFACE And now for the nitty-gritty. =head2 Constructor =head3 C my $conn = DBIx::Connector->new($dsn, $username, $password, { RaiseError => 1, AutoCommit => 1, }); Constructs and returns a DBIx::Connector object. The supported arguments are exactly the same as those supported by the L. Default values for those parameters vary from the DBI as follows: =over =item C Defaults to true if unspecified, and if C is unspecified. Use of the C attribute, or a C attribute that always throws exceptions (such as that provided by L), is required for the exception-handling functionality of L|/"run">, L|/"txn">, and L|/"svp"> to work properly. Their explicit use is therefor recommended if for proper error handling with these execution methods. =item C Added in L 1.613. Defaults to true if unspecified. This is important for safe disconnects across forking processes. =back In addition, explicitly setting C to true is strongly recommended if you plan to use L|/"txn"> or L|/"svp">, as otherwise you won't get the transactional scoping behavior of those two methods. If you would like to execute custom logic each time a new connection to the database is made you can pass a sub as the C key to the C parameter. See L for usage and other available callbacks. Other attributes may be modified by individual drivers. See the documentation for the drivers for details: =over =item L =item L =item L =item L =item L =item L =back =head2 Class Method =head3 C my $dbh = DBIx::Connector->connect($dsn, $username, $password, \%attr); Syntactic sugar for: my $dbh = DBIx::Connector->new(@args)->dbh; Though there's probably not much point in that, as you'll generally want to hold on to the DBIx::Connector object. Otherwise you'd just use the L, no? =head2 Instance Methods =head3 C my $dbh = $conn->dbh; Returns the connection's database handle. It will use a an existing handle if there is one, if the process has not been Ced or a new thread spawned, and if the database is pingable. Otherwise, it will instantiate, cache, and return a new handle. When called from blocks passed to L|/"run">, L|/"txn">, and L|/"svp">, C assumes that the pingability of the database is handled by those methods and skips the C. Otherwise, it performs all the same validity checks. The upshot is that it's safe to call C inside those blocks without the overhead of multiple Cs. Indeed, it's preferable to do so if you're doing lots of non-database processing in those blocks. =head3 C $conn->run(ping => sub { $_->do($query) }); Simply executes the block, locally setting C<$_> to and passing in the database handle. Returns the value returned by the block in scalar or array context as appropriate (and the block can use C to decide what to do). An optional first argument sets the connection mode, overriding that set in the C accessor, and may be one of C, C, or C (the default). See L for further explication. For convenience, you can nest calls to C (or C or C), although the connection mode will be invoked to check the connection (or not) only in the outer-most block method call. $conn->txn(fixup => sub { my $dbh = shift; $dbh->do($_) for @queries; $conn->run(sub { $_->do($expensive_query); $conn->txn(sub { $_->do($another_expensive_query); }); }); }); All code executed inside the top-level call to C will be executed in a single transaction. If you'd like subtransactions, nest L|/svp> calls. It's preferable to use C to fetch the database handle from within the block if your code is doing lots of non-database stuff (shame on you!): $conn->run(ping => sub { parse_gigabytes_of_xml(); # Get this out of the transaction! $conn->dbh->do($query); }); This is because C will better ensure that the database handle is active and C- and thread-safe, although it will never C the database when called from inside a C, C or C block. =head3 C my $sth = $conn->txn(fixup => sub { $_->do($query) }); Starts a transaction, executes the block, locally setting C<$_> to and passing in the database handle, and commits the transaction. If the block throws an exception, the transaction will be rolled back and the exception re-thrown. Returns the value returned by the block in scalar or array context as appropriate (and the block can use C to decide what to do). An optional first argument sets the connection mode, overriding that set in the C accessor, and may be one of C, C, or C (the default). In the case of C mode, this means that the transaction block will be re-executed for a new connection if the database handle is no longer connected. In such a case, a second exception from the code block will cause the transaction to be rolled back and the exception re-thrown. See L for further explication. As with C, calls to C can be nested, although the connection mode will be invoked to check the connection (or not) only in the outer-most block method call. It's preferable to use C to fetch the database handle from within the block if your code is doing lots of non-database processing. =head3 C Executes a code block within the scope of a database savepoint if your database supports them. Returns the value returned by the block in scalar or array context as appropriate (and the block can use C to decide what to do). You can think of savepoints as a kind of subtransaction. What this means is that you can nest your savepoints and recover from failures deeper in the nest without throwing out all changes higher up in the nest. For example: $conn->txn(fixup => sub { my $dbh = shift; $dbh->do('INSERT INTO table1 VALUES (1)'); eval { $conn->svp(sub { shift->do('INSERT INTO table1 VALUES (2)'); die 'OMGWTF?'; }); }; warn "Savepoint failed\n" if $@; $dbh->do('INSERT INTO table1 VALUES (3)'); }); This transaction will insert the values 1 and 3, but not 2. $conn->svp(fixup => sub { my $dbh = shift; $dbh->do('INSERT INTO table1 VALUES (4)'); $conn->svp(sub { shift->do('INSERT INTO table1 VALUES (5)'); }); }); This transaction will insert both 4 and 5. Superficially, C resembles L|/"run"> and L|/"txn">, including its support for the optional L argument, but in fact savepoints can only be used within the scope of a transaction. Thus C will start a transaction for you if it's called without a transaction in-progress. It simply redispatches to C with the appropriate connection mode. Thus, this call from outside of a transaction: $conn->svp(ping => sub { $conn->svp( sub { ... } ); }); Is equivalent to: $conn->txn(ping => sub { $conn->svp( sub { ... } ); }) Savepoints are supported by the following RDBMSs: =over =item * PostgreSQL 8.0 =item * SQLite 3.6.8 =item * MySQL 5.0.3 (InnoDB) =item * Oracle =item * Microsoft SQL Server =item * Firebird 1.5 =back For all other RDBMSs, C works just like C: savepoints will be ignored and the outer-most transaction will be the only transaction. This tends to degrade well for non-savepoint-supporting databases, doing the right thing in most cases. =head3 C my $mode = $conn->mode; $conn->mode('fixup'); $conn->txn(sub { ... }); # uses fixup mode. $conn->mode($mode); Gets and sets the L attribute, which is used by C, C, and C if no mode is passed to them. Defaults to "no_ping". Note that inside a block passed to C, C, or C, the mode attribute will be set to the optional first parameter: $conn->mode('ping'); $conn->txn(fixup => sub { say $conn->mode; # Outputs "fixup" }); say $conn->mode; # Outputs "ping" In this way, you can reliably tell in what mode the code block is executing. =head3 C if ( $conn->connected ) { $conn->dbh->do($query); } Returns true if currently connected to the database and false if it's not. You probably won't need to bother with this method; DBIx::Connector uses it internally to determine whether or not to create a new connection to the database before returning a handle from C. =head3 C if ( $conn->in_txn ) { say 'Transacting!'; } Returns true if the connection is in a transaction. For example, inside a C block it would return true. It will also work if you use the DBI API to manage transactions (i.e., C or C. Essentially, this is just sugar for: $con->run( no_ping => sub { !$_->{AutoCommit} } ); But without the overhead of the code reference or connection checking. =head3 C $conn->disconnect_on_destroy(0); By default, DBIx::Connector calls C<< $dbh->disconnect >> when it goes out of scope and is garbage-collected by the system (that is, in its C method). Usually this is what you want, but in some cases it might not be. For example, you might have a module that uses DBIx::Connector internally, but then makes the database handle available to callers, even after the DBIx::Connector object goes out of scope. In such a case, you don't want the database handle to be disconnected when the DBIx::Connector goes out of scope. So pass a false value to C to prevent the disconnect. An example: sub database_handle { my $conn = DBIx::Connector->new(@_); $conn->run(sub { # Do stuff here. }); $conn->disconnect_on_destroy(0); return $conn->dbh; } Of course, if you don't need to do any work with the database handle before returning it to your caller, you can just use C: sub database_handle { DBIx::Connector->connect(@_); } =head3 C $conn->disconnect; Disconnects from the database. Unless C has been passed a false value, DBIx::Connector uses this method internally in its C method to make sure that things are kept tidy. =head3 C $conn->driver->begin_work( $conn->dbh ); In order to support all database features in a database-neutral way, DBIx::Connector provides a number of different database drivers, subclasses of L, that offer methods to handle database communications. Although the L provides a standard interface, for better or for worse, not all of the drivers implement them, and some have bugs. To avoid those issues, all database communications are handled by these driver objects. This can be useful if you want more fine-grained control of your transactionality. For example, to create your own savepoint within a transaction, you might do something like this: use Try::Tiny; my $driver = $conn->driver; $conn->txn(sub { my $dbh = shift; try { $driver->savepoint($dbh, 'mysavepoint'); # do stuff ... $driver->release('mysavepoint'); } catch { $driver->rollback_to($dbh, 'mysavepoint'); }; }); Most often you should be able to get what you need out of L|/"txn"> and L|/"svp">, but sometimes you just need the finer control. In those cases, take advantage of the driver object to keep your use of the API universal across database back-ends. =head3 C my $driver_name = $conn->driver_name; Returns the name of the L driver (to be) used to connect to the database. =head3 C my $dsn = $conn->dsn; Returns the DBI Data Source Name originally passed to L|/"new"> as the first argument. =head1 SEE ALSO =over =item * L =item * L =item * L =item * L =back =head1 AUTHORS This module was written by: =over =item * David E. Wheeler =back It is based on documentation, ideas, kibbitzing, and code from: =over =item * Tim Bunce =item * Brandon L. Black =item * Matt S. Trout =item * Peter Rabbitson =item * Ash Berlin =item * Rob Kinyon =item * Cory G Watson =item * Anders Nor Berle =item * John Siracusa =item * Alex Pavlovic =item * Many other L =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/000755 000765 000024 00000000000 14705312553 017213 5ustar00apstaff000000 000000 DBIx-Connector-0.60/lib/DBIx/Connector/Driver/000755 000765 000024 00000000000 14705312553 020446 5ustar00apstaff000000 000000 DBIx-Connector-0.60/lib/DBIx/Connector/Driver.pm000644 000765 000024 00000014176 14705311713 021012 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver; our $VERSION = '0.60'; DRIVERS: { my %DRIVERS; sub new { my ($class, $driver) = @_; return $DRIVERS{$driver} ||= do { my $subclass = __PACKAGE__ . "::$driver"; ( my $path = $subclass ) =~ s!::!/!g; local $@; my $ok = eval "require $subclass"; die $@ unless $ok or $@ =~ /^Can't locate $path\.pm in \@INC \(/; bless { driver => $driver } => ( $ok ? $subclass : $class ); }; } } sub _connect { my ($self, $dbh, $dsn, $username, $password, $attrs) = @_; $dbh; } sub ping { my ($self, $dbh) = @_; $dbh->ping; } sub begin_work { my ($self, $dbh) = @_; $dbh->begin_work; } sub commit { my ($self, $dbh) = @_; $dbh->commit; } sub rollback { my ($self, $dbh) = @_; $dbh->rollback; } sub _rollback { my ($self, $dbh, $err) = @_; local $@; eval { $dbh->rollback }; return $@ ? DBIx::Connector::TxnRollbackError->new( error => $err, rollback_error => $@, ) : $err; } sub _rollback_and_release { my ($self, $dbh, $name, $err) = @_; local $@; eval { $self->rollback_to($dbh, $name); $self->release($dbh, $name); }; return $@ ? DBIx::Connector::SvpRollbackError->new( error => $err, rollback_error => $@, ) : $err; } sub savepoint { my ($self, $dbh, $name) = @_; } sub release { my ($self, $dbh, $name) = @_; } sub rollback_to { my ($self, $dbh, $name) = @_; } ROLLBACKERR: { package DBIx::Connector::RollbackError; our $VERSION = '0.58'; # an exception is always true use overload bool => sub {1}, '""' => 'as_string', fallback => 1; sub new { my $c = shift; bless {@_} => $c; } sub error { shift->{error} } sub rollback_error { shift->{rollback_error} } sub as_string { my $self = shift; my $label = $self->_label; return "$label aborted: " . $self->error . "$label rollback failed: " . $self->rollback_error; } package DBIx::Connector::TxnRollbackError; our $VERSION = '0.58'; our @ISA = qw( DBIx::Connector::RollbackError ); sub _label { 'Transaction' } package DBIx::Connector::SvpRollbackError; our $VERSION = '0.58'; our @ISA = qw( DBIx::Connector::RollbackError ); sub _label { 'Savepoint' } } 1; __END__ =head1 NAME DBIx::Connector::Driver - Database-specific connection interface =head1 DESCRIPTION Some of the things that DBIx::Connector does are implemented differently by different drivers, or the official interface provided by the DBI may not be implemented for a particular driver. The driver-specific code therefore is encapsulated in this separate driver class. Most of the DBI drivers work uniformly, so in most cases the implementation provided here in DBIx::Connector::Driver will work just fine. It's only when something is different that a driver subclass needs to be added. In such a case, the subclass's name is the same as the DBI driver. For example the driver for DBD::Pg is L and the driver for DBD::mysql is L. If you're just a user of DBIx::Connector, you can ignore the driver classes. DBIx::Connector uses them internally to do its magic, so you needn't worry about them. =head1 INTERFACE In case you need to implement a driver, here's the interface you can modify. =head2 Constructor =head3 C my $driver = DBIx::Connector::Driver->new( $driver ); Constructs and returns a driver object. Each driver class is implemented as a singleton, so the same driver object is always returned for the same driver. The C parameter should be a Perl DBI driver name, such as C for L or C for L. If a subclass has been defined for C<$driver>, then the object will be of that class. Otherwise it will be an instance of the driver base class. =head2 Instance Methods =head3 C $driver->ping($dbh); Calls C<< $dbh->ping >>. Override if for some reason the DBI driver doesn't do it right. =head3 C $driver->begin_work($dbh); Calls C<< $dbh->begin_work >>. Override if for some reason the DBI driver doesn't do it right. =head3 C $driver->commit($dbh); Calls C<< $dbh->commit >>. Override if for some reason the DBI driver doesn't do it right. =head3 C $driver->rollback($dbh); Calls C<< $dbh->rollback >>. Override if for some reason the DBI driver doesn't do it right. =head3 C $driver->savepoint($dbh, $name); A no-op. Override if your database does in fact support savepoints. The driver subclass should create a savepoint with the given C<$name>. See the implementations in L and L for examples. =head3 C $driver->release($dbh, $name); A no-op. Override if your database does in fact support savepoints. The driver subclass should release the savepoint with the given C<$name>. See the implementations in L and L for examples. =head3 C $driver->rollback_to($dbh, $name); A no-op. Override if your database does in fact support savepoints. The driver subclass should rollback to the savepoint with the given C<$name>. See the implementations in L and L for examples. =head1 AUTHORS This module was written by: =over =item David E. Wheeler =back It is based on code written by: =over =item Matt S. Trout =item Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/Firebird.pm000644 000765 000024 00000002412 14705311713 022526 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::Firebird; use DBIx::Connector::Driver; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver ); sub savepoint { my ($self, $dbh, $name) = @_; $dbh->do("SAVEPOINT $name"); } # Firebird automatically erases a savepoint when you create another # one with the same name. sub release { 1 } sub rollback_to { my ($self, $dbh, $name) = @_; $dbh->do("ROLLBACK TO $name"); } 1; __END__ =head1 NAME DBIx::Connector::Driver::Firebird - Firebird-specific connection interface =head1 DESCRIPTION This subclass of L provides Firebird-specific implementations of the following methods: =over =item C =item C =item C =back =head1 AUTHORS This module was written by: =over =item David E. Wheeler =item Stefan Suciu =back It is based on code written by: =over =item Matt S. Trout =item Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2016 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/MSSQL.pm000644 000765 000024 00000002401 14705311713 021675 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::MSSQL; use DBIx::Connector::Driver; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver ); sub savepoint { my ($self, $dbh, $name) = @_; $dbh->do("SAVE TRANSACTION $name"); } # MSSQL automatically releases a savepoint when you start another one with the # same name. sub release { 1 } sub rollback_to { my ($self, $dbh, $name) = @_; $dbh->do("ROLLBACK TRANSACTION $name"); } 1; __END__ =head1 NAME DBIx::Connector::Driver::MSSQL - Microsoft SQL Server-specific connection interface =head1 DESCRIPTION This subclass of L provides Microsoft SQL server-specific implementations of the following methods: =over =item C =item C =item C =back =head1 AUTHORS This module was written by: =over =item David E. Wheeler =back It is based on code written by: =over =item Matt S. Trout =item Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/Pg.pm000644 000765 000024 00000002543 14705311713 021353 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::Pg; use DBIx::Connector::Driver; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver ); sub savepoint { my ($self, $dbh, $name) = @_; $dbh->pg_savepoint($name); } sub release { my ($self, $dbh, $name) = @_; $dbh->pg_release($name); } sub rollback_to { my ($self, $dbh, $name) = @_; $dbh->pg_rollback_to($name); } 1; __END__ =head1 NAME DBIx::Connector::Driver::Pg - PostgreSQL-specific connection interface =head1 DESCRIPTION This subclass of L provides PostgreSQL-specific implementations of the following methods: =over =item C =item C =item C B Due to L in the implementation of DBD::Pg's C method, DBD::Pg 3.5.0 or later is strongly recommended. =back =head1 AUTHORS This module was written by: =over =item David E. Wheeler =back It is based on code written by: =over =item Matt S. Trout =item Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/SQLite.pm000644 000765 000024 00000003240 14705311713 022141 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::SQLite; use DBIx::Connector::Driver; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver ); sub _connect { my ($self, $dbh, $dsn, $username, $password, $attrs) = @_; my ( $maj, $min, $rel ) = split /[.]/, $dbh->{sqlite_version}; $self->{_sqlite_is_new_enough} = ( $maj <=> 3 || $min <=> 6 || $rel <=> 8 ) != -1; return $dbh; } sub savepoint { my ($self, $dbh, $name) = @_; return unless $self->{_sqlite_is_new_enough}; $dbh->do("SAVEPOINT $name"); } sub release { my ($self, $dbh, $name) = @_; return unless $self->{_sqlite_is_new_enough}; $dbh->do("RELEASE SAVEPOINT $name"); } sub rollback_to { my ($self, $dbh, $name) = @_; return unless $self->{_sqlite_is_new_enough}; $dbh->do("ROLLBACK TO SAVEPOINT $name"); } 1; __END__ =head1 NAME DBIx::Connector::Driver::SQLite - SQLite-specific connection interface =head1 DESCRIPTION This subclass of L provides SQLite-specific implementations of the following methods: =over =item C =item C =item C =back Note that they only work with SQLite 3.6.8 or higher; older versions of SQLite will fallback on the exception-throwing implementation of these methods in L. =head1 AUTHORS This module was written by: =over =item David E. Wheeler =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/MariaDB.pm000644 000765 000024 00000002043 14705311713 022237 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::MariaDB; use DBIx::Connector::Driver::mysql; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver::mysql ); sub _connect { my ($self, $dbh) = @_; $dbh->{mariadb_auto_reconnect} = 0; $dbh; } 1; __END__ =head1 NAME DBIx::Connector::Driver::MariaDB - MariaDB-specific connection interface =head1 DESCRIPTION This subclass of L modifies the connection attributes as follows: =over =item C Will always be set to false. This is to prevent MariaDB's auto-reconnection feature from interfering with DBIx::Connector's auto-reconnection functionality in C mode. =back =head1 AUTHORS This module was written by: =over =item Aristotle Pagaltzis =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2024 Aristotle Pagaltzis. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/Oracle.pm000644 000765 000024 00000003651 14705311713 022213 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::Oracle; use DBIx::Connector::Driver; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver ); # Note from https://rt.cpan.org/Ticket/Display.html?id=47005: # DBD::Oracle has some shutdown state in which it will return 1 on ping as # long as the socket is still open. This however did not guarantee the server # is any longer in a state to execute queries. So what happened was: # # 1) the weird state is reached # 2) a txn_do takes place and fails on the first sql command # 3) the code calls ping() and gets a connected reply # 4) the txn_do is not retried # 5) ... # 6) users lose profit sub ping { my ($self, $dbh) = @_; eval { local $dbh->{RaiseError} = 1; $dbh->do('select 1 from dual'); }; return $@ ? 0 : 1; } sub savepoint { my ($self, $dbh, $name) = @_; $dbh->do("SAVEPOINT $name"); } # Oracle automatically releases a savepoint when you start another one with # the same name. sub release { 1 } sub rollback_to { my ($self, $dbh, $name) = @_; $dbh->do("ROLLBACK TO SAVEPOINT $name"); } 1; __END__ =head1 NAME DBIx::Connector::Driver::Oracle - Oracle-specific connection interface =head1 DESCRIPTION This subclass of L provides Oracle-specific implementations of the following methods: =over =item C =item C =item C =item C =back =head1 AUTHORS This module was written by: =over =item David E. Wheeler =back It is based on code written by: =over =item Matt S. Trout =item Peter Rabbitson =item David Jack Olrik =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/lib/DBIx/Connector/Driver/mysql.pm000644 000765 000024 00000003071 14705311713 022147 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::mysql; use DBIx::Connector::Driver; our $VERSION = '0.60'; our @ISA = qw( DBIx::Connector::Driver ); sub _connect { my ($self, $dbh) = @_; $dbh->{mysql_auto_reconnect} = 0; $dbh; } sub savepoint { my ($self, $dbh, $name) = @_; $dbh->do("SAVEPOINT $name"); } sub release { my ($self, $dbh, $name) = @_; $dbh->do("RELEASE SAVEPOINT $name"); } sub rollback_to { my ($self, $dbh, $name) = @_; $dbh->do("ROLLBACK TO SAVEPOINT $name"); } 1; __END__ =head1 NAME DBIx::Connector::Driver::mysql - MySQL-specific connection interface =head1 DESCRIPTION This subclass of L provides MySQL-specific implementations of the following methods: =over =item C =item C =item C =back It also modifies the connection attributes as follows: =over =item C Will always be set to false. This is to prevent MySQL's auto-reconnection feature from interfering with DBIx::Connector's auto-reconnection functionality in C mode. =back =head1 AUTHORS This module was written by: =over =item David E. Wheeler =back It is based on code written by: =over =item Matt S. Trout =item Peter Rabbitson =back =head1 COPYRIGHT AND LICENSE Copyright (c) 2009-2013 David E. Wheeler. Some Rights Reserved. This module is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut DBIx-Connector-0.60/xt/pod.t000644 000765 000024 00000000235 14701027470 015324 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More; eval "use Test::Pod 1.41"; plan skip_all => "Test::Pod 1.41 required for testing POD" if $@; all_pod_files_ok(); DBIx-Connector-0.60/xt/pod-spelling.t000644 000765 000024 00000001007 14701027470 017135 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More; eval "use Test::Spelling"; plan skip_all => "Test::Spelling required for testing POD spelling" if $@; add_stopwords(); all_pod_files_spelling_ok(); __DATA__ DBI GitHub Pavlovic DBI's nitty Savepoints savepoint savepoints subtransaction subtransactions MySQL MySQL's PostgreSQL Rabbitson Olrik startup transactionality transactionally API SQLite InnoDB SQL Kinyon Siracusa kibbitzing RDBMS pingability pingable RDBMSs fixup redispatches ORMs stringifies Firebird Suciu DBIx-Connector-0.60/xt/pod-coverage.t000644 000765 000024 00000000244 14701027470 017115 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More; eval "use Test::Pod::Coverage 1.06"; plan skip_all => 'Test::Pod::Coverage 1.06 required' if $@; all_pod_coverage_ok(); DBIx-Connector-0.60/t/run_ping.t000644 000765 000024 00000006501 14705311546 016201 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 39; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok $conn->run( ping => sub { ok shift->{AutoCommit}, 'Inside, we should not be in a transaction'; ok !$conn->in_txn, 'in_txn() should know it, too'; ok $conn->{_in_run}, '_in_run should be true'; }), 'Do something with no existing handle'; # Test with instantiated dbh. $connect_meth->restore; ok my $dbh = $conn->dbh, 'Fetch the dbh'; # Set up a DBI mocker. my $ping = 0; my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $conn->{_dbh}, $dbh, 'The dbh should be stored'; is $ping, 0, 'No pings yet'; ok $conn->connected, 'We should be connected'; is $ping, 1, 'Ping should have been called'; ok $conn->run( ping => sub { is $ping, 2, 'Ping should have been called before the run'; is shift, $dbh, 'The database handle should have been passed'; is $_, $dbh, 'Should have dbh in $_'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 2, 'ping should not have been called again'; $dbh->{Active} = 0; isnt $conn->dbh, $dbh, 'Should get different dbh if after disconnect'; }), 'Do something with stored handle'; # Test the return value. $dbh = $conn->dbh; ok my $foo = $conn->run( ping => sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok my @foo = $conn->run( ping => sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; # Test an exception. eval { $conn->run( ping => sub { die 'WTF?' }) }; like $@, qr/WTF/, 'We should have died'; # Make sure nesting works okay. ok !$conn->{_in_run}, '_in_run should be false'; $conn->run( ping => sub { my $dbh = shift; ok $conn->{_in_run}, '_in_run should be set inside run()'; local $dbh->{Active} = 0; $conn->run( ping => sub { my $dbha = shift; isnt $dbha, $dbh, 'Nested should get the same when inactive'; is $_, $dbha, 'Should have dbh in $_'; is $conn->dbh, $dbha, 'Should get same dbh from dbh()'; ok $conn->{_in_run}, '_in_run should be set inside nested run()'; }); }); ok !$conn->{_in_run}, '_in_run should be false again'; # Make sure a nested txn call works, too. ok ++$conn->{_depth}, 'Increase the transacation depth'; ok !($conn->{_dbh}{Active} = 0), 'Disconnect the handle'; $conn->run( ping => sub { is shift, $conn->{_dbh}, 'The txn nested call to run() should get the deactivated handle'; is $_, $conn->{_dbh}, 'Its should also be in $_'; }); # Make sure nesting works when ping returns false. $conn->run( ping => sub { my $dbh = shift; ok $conn->{_in_run}, '_in_run should be set inside run()'; $dbh_ping_meth->replace( sub { 0 } ); $conn->run( ping => sub { is shift, $dbh, 'Nested get the same dbh even if ping is false'; is $_, $dbh, 'Should have dbh in $_'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; ok $conn->{_in_run}, '_in_run should be set inside nested run()'; }); }); DBIx-Connector-0.60/t/svp_ping.t000644 000765 000024 00000006755 14705311546 016220 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 41; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Mock the savepoint driver methods. my @driver_meth = map Hook::Guard->new( $_ )->replace( sub { shift } ), do { package DBIx::Connector::Driver; \*savepoint, \*release, \*rollback_to }; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok my $dbh = $conn->dbh, 'Fetch the database handle'; ok !$conn->{_in_run}, '_in_run should be false'; ok $dbh->{AutoCommit}, 'AutoCommit should be true'; ok !$conn->in_txn, 'in_txn() should return false'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; # This should just pass to txn. ok $conn->svp( ping => sub { ok !shift->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know all about it'; ok $conn->{_in_run}, '_in_run should be true'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; }), 'Do something with no existing handle'; $connect_meth->restore; ok !$conn->{_in_run}, '_in_run should be false again'; ok $dbh->{AutoCommit}, 'Transaction should be committed'; ok !$conn->in_txn, 'in_txn() should know know that, too'; is $conn->{_svp_depth}, 0, 'Depth should still be 0 again'; # Test with instantiated dbh. is $conn->{_dbh}, $dbh, 'The dbh should be stored'; ok $conn->connected, 'We should be connected'; ok $conn->svp( ping => sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know all about it'; }), 'Do something with existing handle'; # Run the same test from inside a transaction, so we're sure that the svp # code executes properly. This is because svp must be called from inside a # txn. If it's not, it just dispatches to txn() and returns. ok $conn->txn(ping => sub { $conn->svp(sub { my $dbha = shift; is $conn->{_mode}, 'ping', 'Should be in ping mode'; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it, too'; }); }), 'Do something inside a transaction'; # Test the return value. Gotta do it inside a transaction. $conn->txn(sub { ok my $foo = $conn->svp( ping => sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok my @foo = $conn->svp( ping => sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; }); # Make sure nested calls work. $conn->svp( ping => sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know all about it'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; local $dbh->{Active} = 0; $conn->svp( ping => sub { is shift, $dbh, 'Nested svp should always get the current dbh'; ok !$dbh->{AutoCommit}, 'Nested txn_runup should be in the txn'; ok $conn->in_txn, 'in_txn() should know all about it, too'; is $conn->{_svp_depth}, 1, 'Depth should be 1'; }); is $conn->{_svp_depth}, 0, 'Depth should be 0 again'; }); DBIx-Connector-0.60/t/txn.t000644 000765 000024 00000016103 14705311546 015170 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 93; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok my $dbh = $conn->dbh, 'Fetch the database handle'; ok $dbh->{AutoCommit}, 'We should not be in a txn'; ok !$conn->in_txn, 'in_txn() should know that, too'; ok !$conn->{_in_run}, '_in_run should be false'; # Set up a DBI mocker. my $ping = 0; my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $conn->{_dbh}, $dbh, 'The dbh should be stored'; is $ping, 0, 'No pings yet'; ok $conn->connected, 'We should be connected'; is $ping, 1, 'Ping should have been called'; ok $conn->txn(sub { is $ping, 1, 'Ping should not have been called before the txn'; ok !shift->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'We should be in a txn'; ok $conn->{_in_run}, '_in_run should be true'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 1, 'ping should not have been called again'; }), 'Do something with no existing handle'; $connect_meth->restore; ok !$conn->{_in_run}, '_in_run should be false again'; ok $dbh->{AutoCommit}, 'Transaction should be committed'; ok !$conn->in_txn, 'in_txn() should know it'; # Test with instantiated dbh. is $conn->{_dbh}, $dbh, 'The dbh should be stored'; ok $conn->connected, 'We should be connected'; ok $conn->txn(sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; is $_, $dbh, 'Should have dbh in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; $ping = 1; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know about it'; }), 'Do something with stored handle'; ok $dbh->{AutoCommit}, 'New transaction should be committed'; ok !$conn->in_txn, 'in_txn() should know it, too'; # Test the return value. ok my $foo = $conn->txn(sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok $foo = $conn->txn(sub { return wantarray ? (2, 3, 5) : 'scalar'; }), 'Do in scalar context'; is $foo, 'scalar', 'Callback should know when its context is scalar'; ok my @foo = $conn->txn(sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; ok @foo = $conn->txn(sub { return wantarray ? (2, 3, 5) : 'scalar'; }), 'Do in scalar context'; is_deeply \@foo, [2, 3, 5], 'Callback should know when its context is list'; # Test an exception. eval { $conn->txn(sub { die 'WTF?' }) }; ok $@, 'We should have died'; ok $dbh->{AutoCommit}, 'New transaction should rolled back'; ok !$conn->in_txn, 'in_txn() should know that'; # Make sure nested calls work. $conn->txn(sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'We should be in a txn'; ok $conn->in_txn, 'in_txn() should know about it'; local $dbh->{Active} = 0; $conn->txn(sub { isnt shift, $dbh, 'Nested txn should not get inactive dbh'; ok !$dbh->{AutoCommit}, 'Nested txn should be in the txn'; ok $conn->in_txn, 'in_txn() should know it'; }); }); # Make sure that it does nothing transactional if we've started the # transaction. $dbh = $conn->dbh; my $driver = $conn->driver; $driver->begin_work($dbh); ok !$dbh->{AutoCommit}, 'Transaction should be started'; ok $conn->in_txn, 'in_txn() should know it'; $conn->txn(sub { my $dbha = shift; is $dbha, $dbh, 'We should have the same database handle'; is $_, $dbh, 'It should also be in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; $ping = 1; ok !$dbha->{AutoCommit}, 'Transaction should still be going'; ok $conn->in_txn, 'in_txn() should know it'; }); ok !$dbh->{AutoCommit}, 'Transaction should stil be live after txn'; ok $conn->in_txn, 'in_txn() should know it'; $driver->rollback($dbh); # Make sure nested calls when ping returns false. $conn->txn(sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'We should be in a txn'; ok $conn->in_txn, 'in_txn() should know that, too'; $dbh_ping_meth->replace( sub { 0 } ); $conn->txn(sub { is shift, $dbh, 'Nested txn should get same dbh, even though inactive'; ok !$dbh->{AutoCommit}, 'Nested txn should be in the txn'; ok $conn->in_txn, 'in_txn() should know that, too'; }); }); # Test mode. $conn->txn(sub { is $conn->mode, 'no_ping', 'Default mode should be no_ping'; }); $conn->txn(ping => sub { is $conn->mode, 'ping', 'Mode should be "ping" inside ping txn' }); is $conn->mode, 'no_ping', 'Back outside, should be "no_ping" again'; $conn->txn(fixup => sub { is $conn->mode, 'fixup', 'Mode should be "fixup" inside fixup txn' }); is $conn->mode, 'no_ping', 'Back outside, should be "no_ping" again'; ok $conn->mode('ping'), 'Se mode to "ping"'; $conn->txn(sub { is $conn->mode, 'ping', 'Mode should implicitly be "ping"' }); ok $conn->mode('fixup'), 'Se mode to "fixup"'; $conn->txn(sub { is $conn->mode, 'fixup', 'Mode should implicitly be "fixup"' }); NOEXIT: { no warnings; my $begin_work_meth = Hook::Guard->new( \*DBIx::Connector::Driver::begin_work )->replace( sub { shift } ); my $keyword; my $commit_meth = Hook::Guard->new( \*DBIx::Connector::Driver::commit )->replace( sub { pass "Commit should be called when returning via $keyword" }); # Make sure we don't exit the app via `next` or `last`. for my $mode (qw(ping no_ping fixup)) { $conn->mode($mode); $keyword = 'next'; ok !$conn->txn(sub { next }), "Return via $keyword should fail"; $keyword = 'last'; ok !$conn->txn(sub { last }), "Return via $keyword should fail"; } } # Have the rollback die. my $dbh_begin_work_meth = Hook::Guard->new( \*DBI::db::begin_work )->replace( sub { return } ); my $dbh_rollback_meth = Hook::Guard->new( \*DBI::db::rollback )->replace( sub { die 'Rollback WTF' } ); eval { $conn->txn(sub { die 'Transaction WTF'; }) }; ok my $err = $@, 'We should have died'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err, qr/Transaction aborted: Transaction WTF/, 'Should have the transaction error'; like $err, qr/Transaction rollback failed: Rollback WTF/, 'Should have the rollback error'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; like $err->error, qr/Transaction WTF/, 'Should have transaction error'; # Try a nested transaction. eval { $conn->txn(sub { local $_->{AutoCommit} = 0; $conn->txn(sub { die 'Nested WTF' }); }) }; ok $err = $@, 'We should have died again'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; like $err->error, qr/Nested WTF/, 'Should have nested transaction error'; ok !ref $err->error, 'The nested error should not be an object'; DBIx-Connector-0.60/t/svp_fixup.t000644 000765 000024 00000006744 14705311546 016414 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 41; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Mock the savepoint driver methods. my @driver_meth = map Hook::Guard->new( $_ )->replace( sub { shift } ), do { package DBIx::Connector::Driver; \*savepoint, \*release, \*rollback_to }; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok my $dbh = $conn->dbh, 'Fetch the database handle'; ok !$conn->{_in_run}, '_in_run should be false'; ok $dbh->{AutoCommit}, 'AutoCommit should be true'; ok !$conn->in_txn, 'in_txn() should know it, too'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; # This should just pass to txn. ok $conn->svp( fixup => sub { ok !shift->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it that'; ok $conn->{_in_run}, '_in_run should be true'; is $conn->{_svp_depth}, 0, 'Depth should still be 0'; }), 'Do something with no existing handle'; $connect_meth->restore; ok !$conn->{_in_run}, '_in_run should be false again'; ok $dbh->{AutoCommit}, 'Transaction should be committed'; ok !$conn->in_txn, 'And in_txn() should know it'; is $conn->{_svp_depth}, 0, 'Depth should be 0 again'; # Test with instantiated dbh. is $conn->{_dbh}, $dbh, 'The dbh should be stored'; ok $conn->connected, 'We should be connected'; ok $conn->svp( fixup => sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know all about it'; }), 'Do something with existing handle'; # Run the same test from inside a transaction, so we're sure that the svp # code executes properly. This is because svp must be called from inside a # txn. If it's not, it just dispatches to txn() and returns. ok $conn->txn(fixup => sub { $conn->svp(sub { my $dbha = shift; is $conn->{_mode}, 'fixup', 'Should be in fixup mode'; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it, too'; }); }), 'Do something inside a transaction'; # Test the return value. Gotta do it inside a transaction. $conn->txn(sub { ok my $foo = $conn->svp( fixup => sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok my @foo = $conn->svp( fixup => sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; }); # Make sure nested calls work. $conn->svp( fixup => sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know all about it'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; local $dbh->{Active} = 0; $conn->svp( fixup => sub { is shift, $dbh, 'Nested svp should always get the current dbh'; ok !$dbh->{AutoCommit}, 'Nested txn_runup should be in the txn'; ok $conn->in_txn, 'in_txn() should know all about it'; is $conn->{_svp_depth}, 1, 'Depth should be 1'; }); is $conn->{_svp_depth}, 0, 'Depth should be 0 again'; }); DBIx-Connector-0.60/t/driver.t000644 000765 000024 00000002167 14705311713 015653 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 14; use DBIx::Connector; use DBIx::Connector::Driver::Pg; # Make sure it's a singleton. ok my $dr = DBIx::Connector::Driver->new( 'ExampleP' ), 'Create a new driver'; isa_ok $dr, 'DBIx::Connector::Driver'; is +DBIx::Connector::Driver->new( 'ExampleP' ), $dr, 'It should be a singleton'; # Subclass should have a different singleton. ok my $pg = DBIx::Connector::Driver::Pg->new( 'Pg' ), 'Get a Pg driver'; isa_ok $pg, 'DBIx::Connector::Driver::Pg'; isa_ok $pg, 'DBIx::Connector::Driver'; isnt $pg, $dr, 'It should be a different object'; is +DBIx::Connector::Driver::Pg->new( 'Pg' ), $pg, 'But it should be a singleton'; is +DBIx::Connector::Driver->new( 'Pg' ), $pg, 'And it should be returned from the factory constructor'; ok my $conn = DBIx::Connector->new( 'dbi:ExampleP:dummy', '', '' ), 'Construct example connection'; is $conn->driver, $dr, 'It should have the driver'; ok $conn = DBIx::Connector->new( 'dbi:Pg:dbname=try', '', '' ), 'Construct a Pg connection'; isa_ok $conn->driver, 'DBIx::Connector::Driver::Pg'; is $conn->driver, $pg, 'It should be the Pg singleton'; DBIx-Connector-0.60/t/svp_live.t000644 000765 000024 00000012533 14705311713 016205 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More; use DBIx::Connector; my (@table_sql, $dsn, $user, $pass); if (exists $ENV{DBICTEST_DSN}) { ($dsn, $user, $pass) = @ENV{map { "DBICTEST_${_}" } qw/DSN USER PASS/}; my $driver = (DBI->parse_dsn($dsn))[1]; if ($driver eq 'Pg') { @table_sql = (q{ SET client_min_messages = warning; DROP TABLE IF EXISTS artist; CREATE TABLE artist (id serial PRIMARY KEY, name TEXT); }); } elsif ($driver eq 'SQLite') { @table_sql = ( 'DROP TABLE IF EXISTS artist', q{CREATE TABLE artist ( id INTEGER NOT NULL PRIMARY KEY AUTOINCREMENT, name TEXT )}, ); } elsif ($driver eq 'Firebird') { @table_sql = ( q{RECREATE TABLE artist (id INTEGER, name VARCHAR(100))}, ); } elsif ($driver eq 'mysql' or $driver eq 'MariaDB') { @table_sql = ( 'DROP TABLE IF EXISTS artist;', q{CREATE TABLE artist ( id INTEGER NOT NULL AUTO_INCREMENT PRIMARY KEY, name TEXT ) ENGINE=InnoDB; }); } else { plan skip_all => 'Set DBICTEST_DSN _USER and _PASS to run savepoint tests'; } } else { plan skip_all => 'Set DBICTEST_DSN _USER and _PASS to run savepoint tests'; } plan tests => 38; ok my $conn = DBIx::Connector->new($dsn, $user, $pass, { PrintError => 0, RaiseError => 1, }), 'Get a connection'; diag "Connecting to $dsn"; ok my $dbh = $conn->dbh, 'Get the database handle'; isa_ok $dbh, 'DBI::db', 'The handle'; $dbh->do($_) for ( @table_sql, "INSERT INTO artist (id, name) VALUES(1, 'foo')", ); pass 'Table created'; my $sel = $dbh->prepare('SELECT name FROM artist WHERE id = 1'); my $upd = $dbh->prepare('UPDATE artist SET name = ? WHERE id = 1'); ok $dbh->begin_work, 'Start a transaction'; is $dbh->selectrow_array($sel), 'foo', 'Name should be "foo"'; my $driver = $conn->driver; # First off, test a generated savepoint name ok $driver->savepoint($dbh, 'foo'), 'Savepoint "foo"'; ok $upd->execute('Jheephizzy'), 'Update to "Jheephizzy"'; is $dbh->selectrow_array($sel), 'Jheephizzy', 'The name should now be "Jheephizzy"'; # Rollback the generated name # Active: 0 ok $driver->rollback_to($dbh, 'foo'), 'Rollback the to "foo"'; is $dbh->selectrow_array($sel), 'foo', 'Name should be "foo" again'; ok $upd->execute('Jheephizzy'), 'Update to "Jheephizzy" again'; # Active: 0 ok $driver->savepoint($dbh, 'testing1'), 'Savepoint testing1'; ok $upd->execute('yourmom'), 'Update to "yourmom"'; # Active: 0 1 ok $driver->savepoint($dbh, 'testing2'), 'Savepont testing2'; ok $upd->execute('gphat'), 'Update to "gphat"'; is $dbh->selectrow_array($sel), 'gphat', 'Name should be "gphat"'; # Active: 0 1 # Rollback doesn't DESTROY the savepoint, it just rolls back to the value # at it's conception ok $driver->rollback_to($dbh, 'testing2'), 'Rollback testing2'; is $dbh->selectrow_array($sel), 'yourmom', 'Name should be "yourmom"'; # Active: 0 1 2 ok $driver->savepoint($dbh, 'testing3'), 'Savepoint testing3'; ok $upd->execute('coryg'), 'Update to "coryg"'; # Active: 0 1 2 3 ok $driver->savepoint($dbh, 'testing4'), 'Savepoint testing4'; ok $upd->execute('watson'), 'Update to "watson"'; # Release 3, which implicitly releases 4 # Active: 0 1 ok $driver->release($dbh, 'testing3'), 'Release testing3'; is $dbh->selectrow_array($sel), 'watson', 'Name should be "watson"'; # This rolls back savepoint 2 # Active: 0 1 ok $driver->rollback_to($dbh, 'testing2'), 'Rollback to [savepoint2]'; is $dbh->selectrow_array($sel), 'yourmom', 'Name should be "yourmom" again'; # Rollback the original savepoint, taking us back to the beginning, implicitly # rolling back savepoint 1 ok $driver->rollback_to($dbh, 'foo'), 'Rollback to the beginning'; is $dbh->selectrow_array($sel), 'foo', 'Name should be "foo" once more'; ok $dbh->commit, 'Commit the changes'; # And now to see if svp will behave correctly $conn->svp (sub { $conn->txn( fixup => sub { $upd->execute('Muff') }); eval { $conn->svp(sub { $upd->execute('Moff'); is $dbh->selectrow_array($sel), 'Moff', 'Name should be "Moff" in nested transaction'; shift->do('SELECT gack from artist'); }); }; ok $@,'Nested transaction failed (good)'; is $dbh->selectrow_array($sel), 'Muff', 'Rolled back name should be "Muff"'; $upd->execute('Miff'); }); is $dbh->selectrow_array($sel), 'Miff', 'Savepoint worked: name is "Muff"'; $conn->txn(fixup => sub { my ($dbh) = @_; $dbh->do("DELETE FROM artist;"); $dbh->do("INSERT INTO artist (name) VALUES ('All-Time Quarterback');"); my $token = \do { my $x = "TURN IT OFF" }; my $ok = eval { $conn->svp(sub { my ($dbh) = @_; $dbh->do("INSERT INTO artist (name) VALUES ('Britney Spears');"); die $token; }); 1; }; my $error = $@; ok( ! $ok, "we didn't survive our svp"); ok( (ref $error && ref $error eq 'SCALAR' && $error == $token), "we got the expected error, too" ) or diag "got error: $error"; $dbh->do("INSERT INTO artist (name) VALUES ('Cyndi Lauper');"); }); $conn->txn(sub { my ($dbh) = @_; my $rows = $dbh->selectcol_arrayref("SELECT name FROM artist ORDER BY name"); is(@$rows, 2, "we inserted 2 rows"); is_deeply( $rows, [ 'All-Time Quarterback', 'Cyndi Lauper' ], "...and we omitted the bad one", ); }); DBIx-Connector-0.60/t/txn_fixup.t000644 000765 000024 00000015764 14705311546 016417 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 92; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok my $dbh = $conn->dbh, 'Fetch the database handle'; ok $dbh->{AutoCommit}, 'We should not be in a txn'; ok !$conn->in_txn, 'in_txn() should know that, too'; ok !$conn->{_in_run}, '_in_run should be false'; # Set up a DBI mocker. my $ping = 0; my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $conn->{_dbh}, $dbh, 'The dbh should be stored'; is $ping, 0, 'No pings yet'; ok $conn->connected, 'We should be connected'; is $ping, 1, 'Ping should have been called'; ok $conn->txn( fixup => sub { is $ping, 1, 'Ping should not have been called before the txn'; ok !shift->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it'; ok $conn->{_in_run}, '_in_run should be true'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 1, 'ping should not have been called again'; }), 'Do something with no existing handle'; $connect_meth->restore; ok !$conn->{_in_run}, '_in_run should be false again'; ok $dbh->{AutoCommit}, 'Transaction should be committed'; ok !$conn->in_txn, 'And in_txn() should know it'; # Test with instantiated dbh. is $conn->{_dbh}, $dbh, 'The dbh should be stored'; ok $conn->connected, 'We should be connected'; ok $conn->txn( fixup => sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; is $_, $dbh, 'Should have dbh in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 0, 'Should have been no ping'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know about that'; }), 'Do something with stored handle'; ok $dbh->{AutoCommit}, 'New transaction should be committed'; ok !$conn->in_txn, 'And in_txn() should know it'; # Test the return value. ok my $foo = $conn->txn( fixup => sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok my @foo = $conn->txn( fixup => sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; # Test an exception. eval { $conn->txn( fixup => sub { die 'WTF?' }) }; ok $@, 'We should have died'; ok $dbh->{AutoCommit}, 'New transaction should rolled back'; ok !$conn->in_txn, 'And in_txn() should know it'; # Test a disconnect. my $die = 1; my $calls; $conn->txn( fixup => sub { my $dbha = shift; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it'; $calls++; if ($die) { is $dbha, $dbh, 'Should have the stored dbh'; is $_, $dbh, 'It should also be in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 0, 'Should have been no ping'; $die = 0; $dbha->{Active} = 0; ok !$dbha->{Active}, 'Disconnect'; die 'WTF?'; } isnt $dbha, $dbh, 'Should have new dbh'; }); ok $dbh = $conn->dbh, 'Get the new handle'; ok $dbh->{AutoCommit}, 'New transaction should be committed'; ok !$conn->in_txn, 'And in_txn() should know it'; is $calls, 2, 'Sub should have been called twice'; # Test disconnect and die. $calls = 0; eval { $conn->txn( fixup => sub { my $dbha = shift; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it'; $dbha->{Active} = 0; if ($calls++) { die 'OMGWTF?'; } else { is $dbha, $dbh, 'Should have the stored dbh again'; is $_, $dbh, 'It should also be in $_'; die 'Disconnected'; } }); }; ok my $err = $@, 'We should have died'; like $@, qr/OMGWTF[?]/, 'We should have killed ourselves'; is $calls, 2, 'Sub should have been called twice'; # Make sure nested calls work. $conn->txn( fixup => sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'We should be in a txn'; ok $conn->in_txn, 'in_txn() should know it'; local $dbh->{Active} = 0; $conn->txn( fixup => sub { isnt shift, $dbh, 'Nested txn_fixup_run should not get inactive dbh'; ok !$dbh->{AutoCommit}, 'Nested txn_fixup_run should be in the txn'; ok $conn->in_txn, 'in_txn() should know it'; }); }); # Make sure that it does nothing transactional if we've started the # transaction. $dbh = $conn->dbh; my $driver = $conn->driver; $driver->begin_work($dbh); ok !$dbh->{AutoCommit}, 'Transaction should be started'; ok $conn->in_txn, 'And in_txn() should know it'; $conn->txn( fixup => sub { my $dbha = shift; is $dbha, $dbh, 'We should have the same database handle'; is $_, $dbh, 'It should also be in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 0, 'Should have been no ping'; ok !$dbha->{AutoCommit}, 'Transaction should still be going'; ok $conn->in_txn, 'in_txn() should know that'; }); ok !$dbh->{AutoCommit}, 'Transaction should stil be live after txn_fixup_run'; $driver->rollback($dbh); # Make sure nested calls when ping returns false. $conn->txn( fixup => sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'We should be in a txn'; ok $conn->in_txn, 'in_txn() should know it'; $dbh_ping_meth->replace( sub { 0 } ); $conn->txn( fixup => sub { is shift, $dbh, 'Nested txn_fixup_run should get same dbh, even though inactive'; ok !$dbh->{AutoCommit}, 'Nested txn_fixup_run should be in the txn'; ok $conn->in_txn, 'in_txn() should know it'; }); }); # Have the rollback die. my $dbh_begin_work_meth = Hook::Guard->new( \*DBI::db::begin_work )->replace( sub { return } ); my $dbh_rollback_meth = Hook::Guard->new( \*DBI::db::rollback )->replace( sub { die 'Rollback WTF' } ); eval { $conn->txn(sub { die 'Transaction WTF'; }) }; ok $err = $@, 'We should have died'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err, qr/Transaction aborted: Transaction WTF/, 'Should have the transaction error'; like $err, qr/Transaction rollback failed: Rollback WTF/, 'Should have the rollback error'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; like $err->error, qr/Transaction WTF/, 'Should have transaction error'; # Try a nested transaction. eval { $conn->txn(sub { local $_->{AutoCommit} = 0; $conn->txn(sub { die 'Nested WTF' }); }) }; ok $err = $@, 'We should have died again'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; like $err->error, qr/Nested WTF/, 'Should have nested transaction error'; ok !ref $err->error, 'The nested error should not be an object'; DBIx-Connector-0.60/t/00-load.t000644 000765 000024 00000002346 14705311704 015513 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More; use File::Find; use File::Spec::Functions qw(catdir splitdir); BEGIN { # compat shim for old Test::More defined &BAIL_OUT or *BAIL_OUT = sub { my $t = Test::Builder->new; $t->no_ending(1); # needed before Test::Builder 0.61 $t->BAILOUT(@_); # added in Test::Builder 0.40 }; } my $CLASS = 'DBIx::Connector'; my @drivers = "$CLASS\::Driver"; find { no_chdir => 1, wanted => sub { s/[.]pm$// or return; my (undef, @path_segment) = splitdir $_; # throw away initial lib/ segment push @drivers, join '::', @path_segment; } }, catdir qw(lib DBIx Connector Driver); plan tests => 2 + 3 * @drivers; # Test the main class. use_ok $CLASS or BAIL_OUT "Could not load $CLASS"; can_ok $CLASS, qw( new dbh connect connected disconnect DESTROY ); # Test the drivers. for my $driver (@drivers) { use_ok $driver or $driver ne "$CLASS\::Driver" or BAIL_OUT "Could not load $driver"; ok eval { $driver->isa( $_ ) }, "'$driver' isa '$_'" for "$CLASS\::Driver"; can_ok $driver, qw( new ping begin_work commit rollback savepoint release rollback_to ); } DBIx-Connector-0.60/t/svp.t000644 000765 000024 00000017133 14705311546 015173 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 87; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Mock the savepoint driver methods. my ( $driver_rollback_to_meth, @driver_meth ) = map Hook::Guard->new( $_ )->replace( sub { shift } ), do { package DBIx::Connector::Driver; \*rollback_to, \*savepoint, \*release }; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok my $dbh = $conn->dbh, 'Fetch the database handle'; ok !$conn->{_in_run}, '_in_run should be false'; ok $dbh->{AutoCommit}, 'AutoCommit should be true'; ok !$conn->in_txn, 'in_txn() should return false'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; # This should just pass to txn. ok $conn->svp(sub { ok !shift->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it, too'; ok $conn->{_in_run}, '_in_run should be true'; is $conn->{_svp_depth}, 0, 'Depth should still be 0'; }), 'Do something with no existing handle'; $connect_meth->restore; ok !$conn->{_in_run}, '_in_run should be false again'; ok $dbh->{AutoCommit}, 'Transaction should be committed'; ok !$conn->in_txn, 'in_txn() should know it, too'; is $conn->{_svp_depth}, 0, 'Depth should be 0 again'; # Test with instantiated dbh. is $conn->{_dbh}, $dbh, 'The dbh should be stored'; ok $conn->connected, 'We should be connected'; ok $conn->svp(sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it, too'; }), 'Do something with stored handle'; # Run the same test from inside a transaction, so we're sure that the svp # code executes properly. This is because svp must be called from inside a # txn. If it's not, it just dispatches to txn() and returns. ok $conn->txn(sub { $conn->svp(sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it, too'; }); }), 'Do something inside a transaction'; # Test the return value. Gotta do it inside a transaction. $conn->txn(sub { ok my $foo = $conn->svp(sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok $foo = $conn->svp(sub { return wantarray ? (2, 3, 5) : 'scalar'; }), 'Do in scalar context'; is $foo, 'scalar', 'Callback should know when its context is scalar'; ok my @foo = $conn->svp(sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; ok @foo = $conn->svp(sub { return wantarray ? (2, 3, 5) : 'scalar'; }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'Callback should know when its context is list'; }); # Make sure nested calls work. $conn->svp(sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know it, too'; is $conn->{_svp_depth}, 0, 'Depth should be 0'; local $dbh->{Active} = 0; $conn->svp(sub { is shift, $dbh, 'Nested svp should always get the current dbh'; ok !$dbh->{AutoCommit}, 'Nested txn should be in the txn'; ok $conn->in_txn, 'in_txn() should know it, too'; is $conn->{_svp_depth}, 1, 'Depth should be 1'; $conn->svp(sub { is shift, $dbh, 'Souble nested svp should get the current dbh'; ok !$dbh->{AutoCommit}, 'Double nested txn should be in the txn'; ok $conn->in_txn, 'in_txn() should know it, too'; is $conn->{_svp_depth}, 2, 'Depth should be 2'; }); }); is $conn->{_svp_depth}, 0, 'Depth should be 0 again'; }); $conn->txn(sub { # Test mode. $conn->svp(sub { is $conn->mode, 'no_ping', 'Default mode should be no_ping'; }); $conn->svp(ping => sub { is $conn->mode, 'ping', 'Mode should be "ping" inside ping svp' }); is $conn->mode, 'no_ping', 'Back outside, should be "no_ping" again'; $conn->svp(fixup => sub { is $conn->mode, 'fixup', 'Mode should be "fixup" inside fixup svp' }); is $conn->mode, 'no_ping', 'Back outside, should be "no_ping" again'; ok $conn->mode('ping'), 'Se mode to "ping"'; $conn->svp(sub { is $conn->mode, 'ping', 'Mode should implicitly be "ping"' }); ok $conn->mode('fixup'), 'Se mode to "fixup"'; $conn->svp(sub { is $conn->mode, 'fixup', 'Mode should implicitly be "fixup"' }); }); NOEXIT: { no warnings; push @driver_meth, Hook::Guard->new( \*DBIx::Connector::Driver::begin_work )->replace( sub { shift } ); my $keyword; push @driver_meth, Hook::Guard->new( \*DBIx::Connector::Driver::commit )->replace( sub { pass "Commit should be called when returning via $keyword" }); $conn->txn(sub { # Make sure we don't exit the app via `next` or `last`. for my $mode (qw(ping no_ping fixup)) { $conn->mode($mode); $keyword = 'next'; ok !$conn->svp(sub { next }), "Return via $keyword should fail"; $keyword = 'last'; ok !$conn->svp(sub { last }), "Return via $keyword should fail"; } }); } # Have the rollback_to die. my $dbh_begin_work_meth = Hook::Guard->new( \*DBI::db::begin_work )->replace( sub { return } ); my $dbh_rollback_meth = Hook::Guard->new( \*DBI::db::rollback ) ->replace( sub { return } ); $driver_rollback_to_meth->replace( sub { die 'ROLLBACK TO WTF' } ); $dbh->{AutoCommit} = 0; # Ensure we run a savepoint. eval { $conn->svp(sub { die 'Savepoint WTF' }) }; ok my $err = $@, 'We should have died'; isa_ok $err, 'DBIx::Connector::SvpRollbackError', 'The exception'; like $err, qr/Savepoint aborted: Savepoint WTF/, 'Should have the savepoint error'; like $err, qr/Savepoint rollback failed: ROLLBACK TO WTF/, 'Should have the savepoint rollback error'; like $err->rollback_error, qr/ROLLBACK TO WTF/, 'Should have rollback error'; like $err->error, qr/Savepoint WTF/, 'Should have savepoint error'; # Try a nested savepoint. eval { $conn->svp(sub { $conn->svp(sub { die 'Nested WTF' }); }) }; ok $err = $@, 'We should have died again'; isa_ok $err, 'DBIx::Connector::SvpRollbackError', 'The exception'; like $err->rollback_error, qr/ROLLBACK TO WTF/, 'Should have rollback error'; like $err->error, qr/Nested WTF/, 'Should have nested savepoint error'; # Now try a savepoint rollback failure *and* a transaction rollback failure. $dbh_rollback_meth->replace( sub { die 'Rollback WTF' } ); $dbh->{AutoCommit} = 1; eval { $conn->txn(sub { local $dbh->{AutoCommit} = 0; $conn->svp(sub { die 'Savepoint WTF' }); }) }; ok $err = $@, 'We should have died'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; isa_ok $err->error, 'DBIx::Connector::SvpRollbackError', 'The savepoint errror'; like $err, qr/Transaction aborted: Savepoint aborted: Savepoint WTF/, 'Stringification should have savepoint errror'; like $err, qr/Savepoint rollback failed: ROLLBACK TO WTF/, 'Stringification should have savepoint rollback failure'; like $err, qr/Transaction rollback failed: Rollback WTF/, 'Stringification should have transaction rollback failure'; DBIx-Connector-0.60/t/lib/000755 000765 000024 00000000000 14705312553 014736 5ustar00apstaff000000 000000 DBIx-Connector-0.60/t/run.t000644 000765 000024 00000011073 14705311546 015164 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 58; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok $conn->run(sub { ok shift->{AutoCommit}, 'Inside, we should not be in a transaction'; ok !$conn->in_txn, 'in_txn() should know it, too'; ok $conn->{_in_run}, '_in_run should be true'; }), 'Do something with no existing handle'; # Test with instantiated dbh. $connect_meth->restore; ok my $dbh = $conn->dbh, 'Fetch the dbh'; # Set up a DBI mocker. my $ping = 0; my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $conn->{_dbh}, $dbh, 'The dbh should be the stored'; is $ping, 0, 'No pings yet'; ok $conn->connected, 'We should be connected'; is $ping, 1, 'Ping should have been called'; ok $conn->run(sub { is $ping, 1, 'Ping should not have been called before the run'; is shift, $dbh, 'The database handle should have been passed'; is $_, $dbh, 'Should have dbh in $_'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 1, 'ping should not have been called again'; $dbh->{Active} = 0; isnt $conn->dbh, $dbh, 'Should get different dbh if after disconnect'; }), 'Do something with handle'; # Test the return value. $dbh = $conn->dbh; ok my $foo = $conn->run(sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok $foo = $conn->run(sub { return wantarray ? (2, 3, 5) : 'scalar'; }), 'Do in scalar context'; is $foo, 'scalar', 'Callback should know when its context is scalar'; ok my @foo = $conn->run(sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; ok @foo = $conn->run(sub { return wantarray ? (2, 3, 5) : 'scalar'; }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'Callback should know when its context is list'; # Test an exception. eval { $conn->run(sub { die 'WTF?' }) }; like $@, qr/WTF/, 'We should have died'; # Make sure nesting works okay. ok !$conn->{_in_run}, '_in_run should be false'; $conn->run(sub { my $dbh = shift; ok $conn->{_in_run}, '_in_run should be set inside run()'; local $dbh->{Active} = 0; $conn->run(sub { my $dbha = shift; isnt $dbha, $dbh, 'Nested should get the same when inactive'; is $_, $dbha, 'Should have dbh in $_'; is $conn->dbh, $dbha, 'Should get same dbh from dbh()'; ok $conn->{_in_run}, '_in_run should be set inside nested run()'; }); }); ok !$conn->{_in_run}, '_in_run should be false again'; # Make sure a nested txn call works, too. ok ++$conn->{_depth}, 'Increase the transacation depth'; ok !($conn->{_dbh}{Active} = 0), 'Disconnect the handle'; $conn->run(sub { is shift, $conn->{_dbh}, 'The txn nested call to run() should get the deactivated handle'; is $_, $conn->{_dbh}, 'Its should also be in $_'; }); # Make sure nesting works when ping returns false. $conn->run(sub { my $dbh = shift; ok $conn->{_in_run}, '_in_run should be set inside run()'; $dbh_ping_meth->replace( sub { 0 } ); $conn->run(sub { is shift, $dbh, 'Nested get the same dbh even if ping is false'; is $_, $dbh, 'Should have dbh in $_'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; ok $conn->{_in_run}, '_in_run should be set inside nested run()'; }); }); # Test mode. $conn->run(sub { is $conn->mode, 'no_ping', 'Default mode should be no_ping'; }); $conn->run(ping => sub { is $conn->mode, 'ping', 'Mode should be "ping" inside ping run' }); is $conn->mode, 'no_ping', 'Back outside, should be "no_ping" again'; $conn->run(fixup => sub { is $conn->mode, 'fixup', 'Mode should be "fixup" inside fixup run' }); is $conn->mode, 'no_ping', 'Back outside, should be "no_ping" again'; ok $conn->mode('ping'), 'Set mode to "ping"'; $conn->run(sub { is $conn->mode, 'ping', 'Mode should implicitly be "ping"' }); ok $conn->mode('fixup'), 'Set mode to "fixup"'; $conn->run(sub { is $conn->mode, 'fixup', 'Mode should implicitly be "fixup"' }); NOEXIT: { no warnings; # Make sure we don't exit the app via `next` or `last`. for my $mode (qw(ping no_ping fixup)) { $conn->mode($mode); ok !$conn->run(sub { next }), "Return via next should fail"; ok !$conn->run(sub { last }), "Return via last should fail"; } } DBIx-Connector-0.60/t/run_fixup.t000644 000765 000024 00000007746 14705311546 016413 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 48; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok $conn->run( fixup => sub { ok shift->{AutoCommit}, 'Inside, we should not be in a transaction'; ok !$conn->in_txn, 'in_txn() should know it, too'; ok $conn->{_in_run}, '_in_run should be true'; }), 'Do something with no existing handle'; # Test with instantiated dbh. $connect_meth->restore; ok my $dbh = $conn->dbh, 'Fetch the dbh'; # Set up a DBI mocker. my $ping = 0; my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $conn->{_dbh}, $dbh, 'The dbh should be stored'; is $ping, 0, 'No pings yet'; ok $conn->connected, 'We should be connected'; is $ping, 1, 'Ping should have been called'; ok $conn->run( fixup => sub { is $ping, 1, 'Ping should not have been called before the run'; is shift, $dbh, 'The database handle should have been passed'; is $_, $dbh, 'Should have dbh in $_'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 1, 'ping should not have been called again'; $dbh->{Active} = 0; isnt $conn->dbh, $dbh, 'Should get different dbh if after disconnect'; }), 'Do something with handle'; # Test the return value. $dbh = $conn->dbh; ok my $foo = $conn->run( fixup => sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok my @foo = $conn->run( fixup => sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; # Test an exception. eval { $conn->run( fixup => sub { die 'WTF?' }) }; like $@, qr/WTF/, 'We should have died'; # Test a disconnect. my $die = 1; my $calls; $conn->run( fixup => sub { my $dbha = shift; ok $conn->{_in_run}, '_in_run should be true'; $calls++; if ($die) { is $_, $dbh, 'Should have dbh in $_'; is $dbha, $dbh, 'Should have stored dbh'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 0, 'Should have been no ping'; $die = 0; $dbha->{Active} = 0; ok !$dbha->{Active}, 'Disconnect'; die 'WTF?'; } isnt $dbha, $dbh, 'Should have new dbh'; }); is $calls, 2, 'Sub should have been called twice'; # Make sure nesting works okay. ok !$conn->{_in_run}, '_in_run should be false'; $conn->run( fixup => sub { my $dbh = shift; ok $conn->{_in_run}, '_in_run should be set inside run( fixup => )'; local $dbh->{Active} = 0; $conn->run( fixup => sub { my $dbha = shift; isnt $dbha, $dbh, 'Nested should get the same when inactive'; is $_, $dbha, 'Should have dbh in $_'; is $conn->dbh, $dbha, 'Should get same dbh from dbh()'; ok $conn->{_in_run}, '_in_run should be set inside nested run( fixup => )'; }); }); ok !$conn->{_in_run}, '_in_run should be false again'; # Make sure a nested txn call works, too. ok ++$conn->{_depth}, 'Increase the transacation depth'; ok !($conn->{_dbh}{Active} = 0), 'Disconnect the handle'; $conn->run( fixup => sub { is shift, $conn->{_dbh}, 'The txn nested call to run( fixup => ) should get the deactivated handle'; is $_, $conn->{_dbh}, 'Its should also be in $_'; }); # Make sure nesting works when ping returns false. $conn->run( fixup => sub { my $dbh = shift; ok $conn->{_in_run}, '_in_run should be set inside run( fixup => )'; $dbh_ping_meth->replace( sub { 0 } ); $conn->run( fixup => sub { is shift, $dbh, 'Nested get the same dbh even if ping is false'; is $_, $dbh, 'Should have dbh in $_'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; ok $conn->{_in_run}, '_in_run should be set inside nested run( fixup => )'; }); }); DBIx-Connector-0.60/t/base.t000644 000765 000024 00000025227 14705311546 015300 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 130; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; BEGIN { $ENV{ DBI_DSN } = undef; $ENV{ DBI_DRIVER } = undef; } # Try the basics. ok my $conn = $CLASS->new, 'Create new connector object'; isa_ok $conn, $CLASS; ok !$conn->connected, 'Should not be connected'; ok !$conn->in_txn, 'Should not be in txn'; eval { $conn->dbh }; ok $@, 'Should get error for no connector args'; ok $conn->disconnect, 'Disconnect should not complain'; # Test mode accessor. is $conn->mode, 'no_ping', 'Mode should be "no_ping"'; ok $conn->mode('fixup'), 'Set mode to "fixup"'; is $conn->mode, 'fixup', 'Mode should now be "fixup"'; ok $conn->mode('ping'), 'Set mode to "ping"'; is $conn->mode, 'ping', 'Mode should now be "ping"'; eval { $conn->mode('foo') }; ok my $e = $@, 'Should get an error for invalid mode'; like $e, qr/Invalid mode: "foo"/, 'It should be the expected error'; # Test disconnect_on_destroy accessor. ok $conn->disconnect_on_destroy, 'Should disconnect on destroy by default'; ok !$conn->disconnect_on_destroy(0), 'Set disconnect on destroy to false'; ok !$conn->disconnect_on_destroy, 'Should no longer disconnect on destroy'; ok $conn->disconnect_on_destroy(12), 'Set disconnect on destroy to true'; ok $conn->disconnect_on_destroy, 'Should disconnect on destroy again'; # Set some connect args. ok $conn = $CLASS->new( 'whatever', 'you', 'want' ), 'Construct object with bad args'; eval { $conn->connect }; ok $@, 'Should get error for bad args'; # Connect f'real. ok $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Construct connector with good args'; isa_ok $conn, $CLASS; ok !$conn->connected, 'Should not yet be connected'; is $conn->{_tid}, undef, 'tid should be undef'; is $conn->{_pid}, undef, 'pid should be undef'; # dbh. ok my $dbh = $conn->dbh, 'Connect to the database'; isa_ok $dbh, 'DBI::db'; is $conn->{_dbh}, $dbh, 'The _dbh attribute should be set'; is $conn->{_tid}, undef, 'tid should still be undef'; is $conn->{_pid}, $$, 'pid should be set'; ok !$conn->in_txn, 'We should not be in a txn'; ok $conn->connected, 'We should be connected'; # Disconnect. my ($rollback, $disconnect, $ping) = (0, 0, 0); my $dbh_disconnect_meth = Hook::Guard->new( \*DBI::db::disconnect )->replace( sub { ++$disconnect } ); my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $ping, 0, 'No pings yet'; ok $conn->disconnect, 'disconnect should execute without error'; is $ping, 0, 'disconnect should not have pinged'; ok $disconnect, 'It should have called disconnect on the database handle'; ok !$rollback, 'But not rollback'; is $conn->{_dbh}, undef, 'The _dbh accessor should now return undef'; # Start a transaction. ok $dbh = $conn->dbh, 'Connect again and start a transaction'; $dbh->{AutoCommit} = 0; $disconnect = 0; ok $conn->disconnect, 'disconnect again'; is $ping, 0, 'disconnect still should not have pinged'; ok $disconnect, 'It should have called disconnect on the database handle'; $dbh->{AutoCommit} = 1; # Clean up after ourselves. # DESTROY. $disconnect = 0; $rollback = 0; ok $conn->DESTROY, 'DESTROY should be fine'; ok !$disconnect, 'Disconnect should not have been called'; ok !$rollback, 'And neither should rollback'; ok my $new = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Instantiate again'; isnt $new, $conn, 'It should be a different object'; ok $dbh = $new->dbh, 'Connect again'; is $ping, 0, 'New handle, no ping'; $dbh->{AutoCommit} = 0; ok $new->DESTROY, 'DESTROY with a connector'; ok $disconnect, 'Disconnect should have been called'; $dbh->{AutoCommit} = 1; # Clean up after ourselves. is $ping, 0, 'Disconnect should not have called ping'; # Check connector args. ok $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Instantiate once more'; ok $dbh = $conn->dbh, 'Connect once more'; is $ping, 0, 'Another new handle, no ping'; ok $dbh->{PrintError}, 'PrintError should be true'; ok $dbh->{RaiseError}, 'RaiseError should be true'; ok $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '', { PrintError => 0, RaiseError => 0, AutoCommit => 0, } ), 'Add attributes to the connect args'; ok $dbh = $conn->dbh, 'Connect with attrs'; is $ping, 0, 'Yet another new handle, another ping'; ok !$dbh->{PrintError}, 'Now PrintError should be false'; ok !$dbh->{RaiseError}, 'And RaiseError should be false'; ok !$dbh->{AutoCommit}, 'And AutoCommit should be false'; ok $conn->in_txn, 'As should in_txn()'; # More dbh. ok $dbh = $conn->dbh, 'Fetch the database handle again'; is $ping, 1, 'Handle should have been pinged'; isa_ok $dbh, 'DBI::db'; ok !$dbh->{PrintError}, 'PrintError should be false'; ok !$dbh->{RaiseError}, 'RaiseError should be false'; # dbh inside a block. BLOCK: { $dbh_ping_meth->replace( sub { pass 'Should not call ping()' } ); is $conn->dbh, $dbh, 'Should get the database handle as usual'; $dbh_ping_meth->replace( sub { fail 'Should not call ping() in a block' } ); local $conn->{_in_run} = 1; is $conn->dbh, $dbh, 'Should get the database handle in do block'; $dbh_ping_meth->restore; } # _dbh is $conn->_dbh, $dbh, '_dbh should work'; is $ping, 1, '_dbh should not have pinged'; # connect $disconnect = 0; ok my $odbh = $CLASS->connect('dbi:ExampleP:dummy', '', '', { PrintError => 0, RaiseError => 1, AutoCommit => 0, }), 'Get a dbh via connect() with same args'; isnt $odbh, $dbh, 'It should not be the same dbh'; $odbh->{AutoCommit} = 1; # Clean up after ourselves. is $disconnect, 0, 'disconnect() should not have been called'; ok my $ddbh = $CLASS->connect('dbi:ExampleP:dummy', '', '' ), 'Get dbh with different args'; isnt $ddbh, $dbh, 'It should be a different database handle'; $dbh->{AutoCommit} = 1; # Clean up after ourselves. is $disconnect, 0, 'disconnect() still should not have been called'; ok $dbh = $CLASS->connect('dbi:ExampleP:dummy', '', '' ), 'Get dbh with the same args again'; isnt $dbh, $odbh, 'It should be a different database handle'; is $disconnect, 0, 'disconnect() still should not have been called'; $dbh->{AutoCommit} = 1; # Clean up after ourselves. # disconnect_on_destroy. DOND: { ok my $conn = $CLASS->new('dbi:ExampleP:dummy', '', '' ), 'Create new connection'; ok !$conn->disconnect_on_destroy(0), 'Disable disconnect on destroy'; ok $conn->dbh, 'Get the database handle'; is $disconnect, 0, 'disconnect() should not have been called'; } # Apache::DBI. APACHEDBI: { local $INC{'Apache/DBI.pm'} = __FILE__; local $ENV{MOD_PERL} = 1; local $DBI::connect_via = "Apache::DBI::connect"; my $dbi_connect_meth = Hook::Guard->new( \*DBI::connect )->replace( sub { is $DBI::connect_via, 'connect', 'Apache::DBI should be disabled'; $dbh; } ); $conn->_connect; } FORK: { ok $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Construct for PID tests'; ok my $dbh = $conn->dbh, 'Get its database handle'; # Expire based on PID. local *$; $$ = -42; ok !$dbh->{InactiveDestroy}, 'InactiveDestroy should be false'; ok my $new_dbh = $conn->dbh, 'Fetch with different PID'; isnt $new_dbh, $dbh, 'It should be a different handle'; ok $dbh->{InactiveDestroy}, 'InactiveDestroy should be true for old handle'; # Do the same for _dbh. is $conn->_dbh, $new_dbh, '_dbh should return same dbh'; $$ = -99; ok !$new_dbh->{InactiveDestroy}, 'InactiveDestroy should be false in new handle'; ok $dbh = $conn->_dbh, 'Call _dbh again'; isnt $dbh, $new_dbh, 'It should be a new handle'; ok $new_dbh->{InactiveDestroy}, 'InactiveDestroy should be true for second handle'; # Expire based on active (!connected). $dbh->{Active} = 0; ok $new_dbh = $conn->dbh, 'Fetch for inactive handle'; isnt $new_dbh, $dbh, 'It should be yet another handle'; # Connection check should be ignored by _dbh. $new_dbh->{Active} = 0; ok !$new_dbh->{Active}, 'Handle should be inactive'; isnt $dbh = $conn->_dbh, $new_dbh, '_dbh should not return inactive handle'; # Check _seems_connected, just to be sane. ok $dbh = $conn->dbh, 'Get a new handle'; ok $conn->_seems_connected, 'Should seem connected'; $dbh->{Active} = 0; ok !$dbh->{Active}, 'Deactivate'; ok !$conn->_seems_connected, 'Should no longer seem connected'; } # Connect with threads. THREAD: { ok $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Construct for TID tests'; ok my $dbh = $conn->dbh, 'Get its database handle'; # Mock up threads. local $INC{'threads.pm'} = __FILE__; no strict 'refs'; my $tid = 42; local *{'threads::tid'} = sub { $tid }; # Expire based on TID. $conn->{_pid} = -42; is $conn->{_pid}, -42, 'pid should be wrong'; is $conn->{_tid}, undef, 'tid should be undef'; ok $dbh = $conn->dbh, 'Connect to the database with threads'; is $conn->{_tid}, 42, 'tid should now be set'; is $conn->{_pid}, $$, 'pid should be set again'; # Test how a different tid resets the handle. $tid = 43; ok my $new_dbh = $conn->dbh, 'Get new threaded handle'; isnt $new_dbh, $dbh, 'It should be a different handle'; # Do the same for _dbh. is $conn->_dbh, $new_dbh, '_dbh should return same dbh'; $tid = 99; ok $dbh = $conn->_dbh, 'Call _dbh again with new tid'; isnt $dbh, $new_dbh, 'It should be a new handle'; is $conn->{_tid}, 99, 'And the tid should be set'; $conn->DESTROY; # Clean up after ourselves. } SKIP: { skip 'AutoInactiveDestroy in DBI 1.614 and higher', 5 unless DBI->VERSION > 1.613; my @args = ('dbi:ExampleP:dummy', '', ''); ok $CLASS->new(@args)->dbh->{AutoInactiveDestroy}, 'AutoInactiveDestroy should be set when no attributes'; push @args, {}; ok $CLASS->new(@args)->dbh->{AutoInactiveDestroy}, 'AutoInactiveDestroy should be set when empty attrs'; $args[3]{RaiseError} = 1; ok $CLASS->new(@args)->dbh->{AutoInactiveDestroy}, 'AutoInactiveDestroy should be set when not passed'; $args[3]{AutoInactiveDestroy} = 1; ok $CLASS->new(@args)->dbh->{AutoInactiveDestroy}, 'AutoInactiveDestroy should be set when passed true'; $args[3]{AutoInactiveDestroy} = 0; ok !$CLASS->new(@args)->dbh->{AutoInactiveDestroy}, 'AutoInactiveDestroy should not be true when passed false'; } HANDLEERROR: { # Try with a HandleError param. local $ENV{FOO} = 1; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '', { HandleError => sub { }, } ), 'Add HandleError to connect args'; ok $dbh = $conn->dbh, 'Grab the database handle'; ok $dbh->{PrintError}, 'PrintError should be true'; ok $dbh->{HandleError}, 'And HandleError should be true'; ok !$dbh->{RaiseError}, 'And RaiseError should be false'; } DBIx-Connector-0.60/t/txn_ping.t000644 000765 000024 00000013035 14705311546 016206 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 68; use lib 't/lib'; use Hook::Guard; use DBIx::Connector; my $CLASS = 'DBIx::Connector'; ok my $conn = $CLASS->new( 'dbi:ExampleP:dummy', '', '' ), 'Get a connection'; # Test with no existing dbh. my $connect_meth = Hook::Guard->new( \*DBIx::Connector::_connect )->prepend(sub { pass '_connect should be called'; }); ok my $dbh = $conn->dbh, 'Fetch the database handle'; ok $dbh->{AutoCommit}, 'We should not be in a txn'; ok !$conn->in_txn, 'in_txn() should know it'; ok !$conn->{_in_run}, '_in_run should be false'; # Set up a DBI mocker. my $ping = 0; my $dbh_ping_meth = Hook::Guard->new( \*DBI::db::ping )->replace( sub { ++$ping } ); is $conn->{_dbh}, $dbh, 'The dbh should be stored'; is $ping, 0, 'No pings yet'; ok $conn->connected, 'We should be connected'; is $ping, 1, 'Ping should have been called'; ok $conn->txn( ping => sub { is $ping, 2, 'Ping should have been called before the txn_ping_run'; ok !shift->{AutoCommit}, 'Inside, we should be in a transaction'; ok $conn->in_txn, 'in_txn() should know that'; ok $conn->{_in_run}, '_in_run should be true'; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; is $ping, 2, 'ping should not have been called again'; }), 'Do something with no existing handle'; $connect_meth->restore; ok !$conn->{_in_run}, '_in_run should be false again'; ok $dbh->{AutoCommit}, 'Transaction should be committed'; ok !$conn->in_txn, 'in_txn() should recognize that'; # Test with instantiated dbh. is $conn->{_dbh}, $dbh, 'The dbh should be stored'; ok $conn->connected, 'We should be connected'; ok $conn->txn( ping => sub { my $dbha = shift; is $dbha, $dbh, 'The handle should have been passed'; is $_, $dbh, 'It should also be in $_'; is $_, $dbh, 'Should have dbh in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; $ping = 1; ok !$dbha->{AutoCommit}, 'We should be in a transaction'; ok $conn->in_txn, 'in_txn() should recognize that'; }), 'Do something with stored handle'; ok $dbh->{AutoCommit}, 'New transaction should be committed'; ok !$conn->in_txn, 'in_txn() should be all about that'; # Test the return value. ok my $foo = $conn->txn( ping => sub { return (2, 3, 5); }), 'Do in scalar context'; is $foo, 5, 'The return value should be the last value'; ok my @foo = $conn->txn( ping => sub { return (2, 3, 5); }), 'Do in array context'; is_deeply \@foo, [2, 3, 5], 'The return value should be the list'; # Test an exception. eval { $conn->txn( ping => sub { die 'WTF?' }) }; ok $@, 'We should have died'; ok $dbh->{AutoCommit}, 'New transaction should rolled back'; ok !$conn->in_txn, 'in_txn() should be all over that'; # Make sure nested calls work. $conn->txn( ping => sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'We should be in a txn'; ok $conn->in_txn, 'in_txn() should know it'; local $dbh->{Active} = 0; $conn->txn( ping => sub { isnt shift, $dbh, 'Nested txn_ping_run should not get inactive dbh'; ok !$dbh->{AutoCommit}, 'Nested txn_ping_run should be in the txn'; ok $conn->in_txn, 'in_txn() should know it'; }); }); # Make sure that it does nothing transactional if we've started the # transaction. $dbh = $conn->dbh; my $driver = $conn->driver; $driver->begin_work($dbh); ok !$dbh->{AutoCommit}, 'Transaction should be started'; ok $conn->in_txn, 'in_txn() should know it'; $conn->txn( ping => sub { my $dbha = shift; is $dbha, $dbh, 'We should have the same database handle'; is $_, $dbh, 'It should also be in $_'; $ping = 0; is $conn->dbh, $dbh, 'Should get same dbh from dbh()'; $ping = 1; ok !$dbha->{AutoCommit}, 'Transaction should still be going'; ok $conn->in_txn, 'in_txn() should know it'; }); ok !$dbh->{AutoCommit}, 'Transaction should stil be live after txn_ping_run'; ok $conn->in_txn, 'in_txn() should know it still!'; $driver->rollback($dbh); # Make sure nested calls when ping returns false. $conn->txn( ping => sub { my $dbh = shift; ok !$dbh->{AutoCommit}, 'We should be in a txn'; ok $conn->in_txn, 'in_txn() should know it'; $dbh_ping_meth->replace( sub { 0 } ); $conn->txn( ping => sub { is shift, $dbh, 'Nested txn_ping_run should get same dbh, even though inactive'; ok !$dbh->{AutoCommit}, 'Nested txn_ping_run should be in the txn'; ok $conn->in_txn, 'in_txn() should know it'; }); }); # Have the rollback die. my $dbh_begin_work_meth = Hook::Guard->new( \*DBI::db::begin_work )->replace( sub { return } ); my $dbh_rollback_meth = Hook::Guard->new( \*DBI::db::rollback )->replace( sub { die 'Rollback WTF' } ); eval { $conn->txn(sub { die 'Transaction WTF'; }) }; ok my $err = $@, 'We should have died'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err, qr/Transaction aborted: Transaction WTF/, 'Should have the transaction error'; like $err, qr/Transaction rollback failed: Rollback WTF/, 'Should have the rollback error'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; like $err->error, qr/Transaction WTF/, 'Should have transaction error'; # Try a nested transaction. eval { $conn->txn(sub { local $_->{AutoCommit} = 0; $conn->txn(sub { die 'Nested WTF' }); }) }; ok $err = $@, 'We should have died again'; isa_ok $err, 'DBIx::Connector::TxnRollbackError', 'The exception'; like $err->rollback_error, qr/Rollback WTF/, 'Should have rollback error'; like $err->error, qr/Nested WTF/, 'Should have nested transaction error'; ok !ref $err->error, 'The nested error should not be an object'; DBIx-Connector-0.60/t/lib/Hook/000755 000765 000024 00000000000 14705312553 015636 5ustar00apstaff000000 000000 DBIx-Connector-0.60/t/lib/Hook/Guard.pm000644 000765 000024 00000001537 14701027467 017247 0ustar00apstaff000000 000000 use strict; use warnings; package Hook::Guard; sub new { my ( $class, $glob ) = ( shift, @_ ); local $@; my $code = eval { *$glob{'CODE'} } or die sprintf "Cannot hook a %s at %s line %d.\n", ( ( $@ ? 'non-glob' : 'glob with an empty CODE slot' ), ( caller )[1,2], ); bless [ $glob, $code ], $class; } sub glob { $_[0][0] } sub original { $_[0][1] } sub current { *{ shift->glob }{'CODE'} } sub replace { my $self = shift; no warnings 'redefine'; *{ $self->glob } = \&{ $_[0] }; $self } sub restore { my $self = shift; no warnings 'redefine'; *{ $self->glob } = $self->original; $self } sub prepend { my $self = shift; my $combined = do { # new pad to avoid capturing $self my $sub = shift; my $current = $self->current; sub { $sub->( @_ ); &$current }; }; $self->replace( $combined ); } sub DESTROY { shift->restore } 1; DBIx-Connector-0.60/inc/boilerplate.pl000644 000765 000024 00000003007 14701027467 017340 0ustar00apstaff000000 000000 use strict; use warnings; use CPAN::Meta; use Software::LicenseUtils 0.103011; use Pod::Readme::Brief 1.003; sub slurp { open my $fh, '<', $_[0] or die "Couldn't open $_[0] to read: $!\n"; local $/; readline $fh } sub trimnl { s/\A\s*\n//, s/\s*\z/\n/ for @_; wantarray ? @_ : $_[-1] } sub mkparentdirs { my @dir = do { my %seen; sort grep s!/[^/]+\z!! && !$seen{ $_ }++, my @copy = @_ }; if ( @dir ) { mkparentdirs( @dir ); mkdir for @dir } } chdir $ARGV[0] or die "Cannot chdir to $ARGV[0]: $!\n"; my %file; my $meta = CPAN::Meta->load_file( 'META.json' ); my $license = do { my @key = ( $meta->license, $meta->meta_spec_version ); my ( $class, @ambiguous ) = Software::LicenseUtils->guess_license_from_meta_key( @key ); die if @ambiguous or not $class; $class->new( $meta->custom( 'x_copyright' ) ); }; $file{'LICENSE'} = trimnl $license->fulltext; my ( $main_module ) = map { s!-!/!g; s!^!lib/! if -d 'lib'; -f "$_.pod" ? "$_.pod" : "$_.pm" } $meta->name; die unless -e 'Makefile.PL'; $file{'README'} = Pod::Readme::Brief->new( slurp $main_module )->render( installer => 'eumm', width => 72 ); my @manifest = split /\n/, slurp 'MANIFEST'; my %manifest = map /\A([^\s#]+)()/, @manifest; $file{'MANIFEST'} = join "\n", @manifest, ( sort grep !exists $manifest{ $_ }, keys %file ), ''; mkparentdirs sort keys %file; for my $fn ( sort keys %file ) { unlink $fn if -e $fn; open my $fh, '>', $fn or die "Couldn't open $fn to write: $!\n"; print $fh $file{ $fn }; close $fh or die "Couldn't close $fn after writing: $!\n"; } DBIx-Connector-0.60/inc/WriteMakefile.pl000644 000765 000024 00000004044 14701027467 017570 0ustar00apstaff000000 000000 use strict; use warnings; require ExtUtils::MakeMaker; defined(our $distlib) or ($distlib = -d 'lib' ? 'lib' : '.'); defined(our $manifest_cmd) or ($manifest_cmd = "git ls-files ':!README.pod'"); sub MY::postamble { -f 'META.yml' ? return : <<"" } create_distdir : MANIFEST distdir : MANIFEST MANIFEST : ( $manifest_cmd ; echo MANIFEST ) > MANIFEST distdir : boilerplate .PHONY : boilerplate boilerplate : distmeta \$(PERL) -I$distlib inc/boilerplate.pl \$(DISTVNAME) our (%META, %MM_ARGS); # have to do this since old EUMM dev releases miss the eval $VERSION line my $eumm_version = eval $ExtUtils::MakeMaker::VERSION; my $mymeta = $eumm_version >= 6.57_02; my $mymeta_broken = $mymeta && $eumm_version < 6.57_07; (my $basepath = "$distlib/$META{name}") =~ s{-}{/}g; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; $MM_ARGS{VERSION_FROM} = "$basepath.pm"; $MM_ARGS{ABSTRACT_FROM} = -f "$basepath.pod" ? "$basepath.pod" : "$basepath.pm"; $META{license} = [ $META{license} ] if $META{license} && !ref $META{license}; $MM_ARGS{LICENSE} = $META{license}[0] if $META{license} && $eumm_version >= 6.30; $MM_ARGS{NO_MYMETA} = 1 if $mymeta_broken; $MM_ARGS{META_ADD} = { 'meta-spec' => { version => 2 }, %META } unless -f 'META.yml'; $MM_ARGS{PL_FILES} ||= {}; $MM_ARGS{NORECURS} = 1 if not exists $MM_ARGS{NORECURS}; for (qw(configure build test runtime)) { my $key = $_ eq 'runtime' ? 'PREREQ_PM' : uc $_.'_REQUIRES'; my $r = $MM_ARGS{$key} = { %{$META{prereqs}{$_}{requires} || {}}, %{delete $MM_ARGS{$key} || {}}, }; defined $r->{$_} or delete $r->{$_} for keys %$r; } $MM_ARGS{MIN_PERL_VERSION} = eval delete $MM_ARGS{PREREQ_PM}{perl} || 0; delete $MM_ARGS{MIN_PERL_VERSION} if $eumm_version < 6.47_01; $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; delete $MM_ARGS{CONFIGURE_REQUIRES} if $eumm_version < 6.51_03; ExtUtils::MakeMaker::WriteMakefile(%MM_ARGS);