DBIx-Connector-0.57/000755 000765 000024 00000000000 14124315417 013730 5ustar00apstaff000000 000000 DBIx-Connector-0.57/Changes000644 000765 000024 00000033633 14124315137 015232 0ustar00apstaff000000 000000 Revision history for Perl extension DBIx::Connector. 0.57 2021-09-27 - `$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 2016-03-16 - 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 2016-02-05 - Added versions to the RollbackError exception classes to make PAUSE happy. 0.54 2016-02-05 - 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 2013-03-20 - 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 2012-05-29 - 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 2012-02-18 - Fixed internal exception handling on Perls less than 5.14, where some exceptions woult not be propagated to the caller. 0.50 2012-02-14 - 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 2011-09-26 - Use of the deprecated `catch` functionality now warns on every call, rather than just the first call from a given caller. 0.46 2011-07-17 - 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 2011-05-10 - 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 2011-03-20 - Fixed bug with the MySQL driver introduced by the auto-reconnection fix in 0.43. Sorry for the lame mistake. [Lee Aylward] 0.43 2011-03-17 - 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 2010-12-17 - 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 2010-12-08 - `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 2010-09-17 - 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 2010-06-04 - 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 2010-05-03 - 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 2010-03-31 - 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 2010-02-22 - 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 2009-11-09 - 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 2009-10-29 - 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 2009-10-20 - 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 2009-10-06 - 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 2009-10-05 - 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 2009-10-05 - Initial version, with code borrowed from DBIx::Class, Apache::DBI, Catalyst::Model::DBI, and various other locales. DBIx-Connector-0.57/lib/000755 000765 000024 00000000000 14124315416 014475 5ustar00apstaff000000 000000 DBIx-Connector-0.57/Makefile.PL000644 000765 000024 00000004731 14124315137 015706 0ustar00apstaff000000 000000 use 5.008001; use strict; use warnings; my $u = 'github.com/ap/DBIx-Connector'; my %META = ( name => 'DBIx-Connector', license => 'perl_5', prereqs => { test => { requires => {qw( Test::More 0 )}, }, runtime => { requires => {qw( perl 5.008001 DBI 1.605 )}, recommends => {qw( DBI 1.614 )}, } }, resources => { repository => { type => 'git', url => "git://$u.git", web => "https://$u" }, bugtracker => { web => "https://$u/issues" }, license => [ 'http://dev.perl.org/licenses/' ], }, ); sub MY::postamble { -f 'META.yml' ? return : <<'' } create_distdir : MANIFEST distdir : MANIFEST MANIFEST : ( git ls-files ':!README.pod' . ; echo MANIFEST ) | sort -f > MANIFEST ## BOILERPLATE ############################################################### require ExtUtils::MakeMaker; my %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; ($MM_ARGS{NAME} = $META{name}) =~ s/-/::/g; ($MM_ARGS{VERSION_FROM} = "lib/$MM_ARGS{NAME}.pm") =~ s{::}{/}g; $MM_ARGS{ABSTRACT_FROM} = $MM_ARGS{VERSION_FROM}; $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} = 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); ## END BOILERPLATE ########################################################### DBIx-Connector-0.57/MANIFEST000644 000765 000024 00000001240 14124315417 015056 0ustar00apstaff000000 000000 Changes 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/mysql.pm lib/DBIx/Connector/Driver/Oracle.pm lib/DBIx/Connector/Driver/Pg.pm lib/DBIx/Connector/Driver/SQLite.pm Makefile.PL MANIFEST t/base.t t/driver.t t/lib/Hook/Guard.pm t/load.t 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 META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) DBIx-Connector-0.57/META.json000644 000765 000024 00000002456 14124315417 015360 0ustar00apstaff000000 000000 { "abstract" : "Fast, safe DBI connection and transaction management", "author" : [ "unknown" ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 7.1002, CPAN::Meta::Converter version 2.150005", "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" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/ap/DBIx-Connector.git", "web" : "https://github.com/ap/DBIx-Connector" } }, "version" : "0.57", "x_serialization_backend" : "JSON::PP version 2.27300_01" } DBIx-Connector-0.57/META.yml000644 000765 000024 00000001303 14124315417 015176 0ustar00apstaff000000 000000 --- abstract: 'Fast, safe DBI connection and transaction management' author: - unknown build_requires: Test::More: '0' dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 7.1002, CPAN::Meta::Converter version 2.150005' 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: http://dev.perl.org/licenses/ repository: git://github.com/ap/DBIx-Connector.git version: '0.57' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' DBIx-Connector-0.57/t/000755 000765 000024 00000000000 14124315416 014172 5ustar00apstaff000000 000000 DBIx-Connector-0.57/xt/000755 000765 000024 00000000000 14124315416 014362 5ustar00apstaff000000 000000 DBIx-Connector-0.57/xt/pod-coverage.t000644 000765 000024 00000000244 14124315137 017122 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.57/xt/pod-spelling.t000644 000765 000024 00000001007 14124315137 017142 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.57/xt/pod.t000644 000765 000024 00000000235 14124315137 015331 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.57/t/base.t000644 000765 000024 00000025303 14124315137 015274 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 131; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; $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.57/t/driver.t000644 000765 000024 00000002767 14124315137 015666 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 34; #use Test::More 'no_plan'; my $CLASS; my @SUBCLASSES; BEGIN { $CLASS = 'DBIx::Connector::Driver'; use_ok $CLASS or die; use_ok 'DBIx::Connector' or die; @SUBCLASSES = map { "$CLASS\::$_" } qw(MSSQL Oracle Pg SQLite mysql Firebird); use_ok $_ for @SUBCLASSES; } # Validate the subclasses. for my $dr (@SUBCLASSES) { ok eval { $dr->isa( $CLASS ) }, "The class (or class-like) '$dr' isa '$CLASS'"; can_ok $dr => qw( new ping begin_work commit rollback savepoint release rollback_to ); } # Make sure it's a singleton. ok my $dr = $CLASS->new( 'ExampleP'), 'Create a new driver'; isa_ok $dr, $CLASS; is $CLASS->new('ExampleP'), $dr, 'It should be a singleton'; # Subclass should have a different singleton. ok my $pg = "$CLASS\::Pg"->new( 'Pg' ), 'Get a Pg driver'; isa_ok $pg, "$CLASS\::Pg"; isa_ok $pg, $CLASS; isnt $pg, $dr, 'It should be a different object'; is "$CLASS\::Pg"->new('Pg'), $pg, 'But it should be a singleton'; is $CLASS->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.57/t/lib/000755 000765 000024 00000000000 14124315416 014740 5ustar00apstaff000000 000000 DBIx-Connector-0.57/t/load.t000644 000765 000024 00000001734 14124315137 015303 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More; use File::Find; use File::Spec::Functions qw(catdir splitdir); my $CLASS; my @drivers; BEGIN { $CLASS = 'DBIx::Connector'; my $dir = catdir qw(lib DBIx Connector Driver); my $qdir = quotemeta $dir; find { no_chdir => 1, wanted => sub { s/[.]pm$// or return; s{^$qdir/?}{}; push @drivers, "$CLASS\::Driver::" . join( '::', splitdir $_); } }, $dir; } plan tests => (@drivers * 3) + 3; # Test the main class. use_ok $CLASS or die; can_ok $CLASS, qw( new dbh connect connected disconnect DESTROY ); # Test the drivers. use_ok "$CLASS\::Driver"; for my $driver (@drivers) { use_ok $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.57/t/run.t000644 000765 000024 00000011157 14124315137 015170 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 59; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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'), 'Se mode to "ping"'; $conn->run(sub { is $conn->mode, 'ping', 'Mode should implicitly be "ping"' }); ok $conn->mode('fixup'), 'Se 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.57/t/run_fixup.t000644 000765 000024 00000010034 14124315137 016374 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 49; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/run_ping.t000644 000765 000024 00000006567 14124315137 016216 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 40; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/svp.t000644 000765 000024 00000017221 14124315137 015172 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 88; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/svp_fixup.t000644 000765 000024 00000007032 14124315137 016404 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 42; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/svp_live.t000644 000765 000024 00000012503 14124315137 016207 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') { @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.57/t/svp_ping.t000644 000765 000024 00000007043 14124315137 016210 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 42; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/txn.t000644 000765 000024 00000016171 14124315137 015176 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 94; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/txn_fixup.t000644 000765 000024 00000016052 14124315137 016407 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 93; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/txn_ping.t000644 000765 000024 00000013123 14124315137 016205 0ustar00apstaff000000 000000 use strict; use warnings; use Test::More tests => 69; #use Test::More 'no_plan'; use lib 't/lib'; use Hook::Guard; my $CLASS; BEGIN { $CLASS = 'DBIx::Connector'; use_ok $CLASS or die; } 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.57/t/lib/Hook/000755 000765 000024 00000000000 14124315416 015640 5ustar00apstaff000000 000000 DBIx-Connector-0.57/t/lib/Hook/Guard.pm000644 000765 000024 00000001537 14124315137 017246 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.57/lib/DBIx/000755 000765 000024 00000000000 14124315416 015263 5ustar00apstaff000000 000000 DBIx-Connector-0.57/lib/DBIx/Connector/000755 000765 000024 00000000000 14124315416 017215 5ustar00apstaff000000 000000 DBIx-Connector-0.57/lib/DBIx/Connector.pm000644 000765 000024 00000076030 14124315137 017561 0ustar00apstaff000000 000000 use 5.008001; use strict; use warnings; package DBIx::Connector; use DBI '1.605'; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/000755 000765 000024 00000000000 14124315416 020450 5ustar00apstaff000000 000000 DBIx-Connector-0.57/lib/DBIx/Connector/Driver.pm000644 000765 000024 00000013763 14124315137 021020 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver; our $VERSION = '0.57'; DRIVERS: { my %DRIVERS; sub new { my ($class, $driver) = @_; return $DRIVERS{$driver} ||= do { my $subclass = __PACKAGE__ . "::$driver"; eval "require $subclass"; $class = $subclass unless $@; bless { driver => $driver } => $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.57'; # 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.57'; our @ISA = qw( DBIx::Connector::RollbackError ); sub _label { 'Transaction' } package DBIx::Connector::SvpRollbackError; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/Firebird.pm000644 000765 000024 00000002412 14124315137 022533 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::Firebird; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/MSSQL.pm000644 000765 000024 00000002401 14124315137 021702 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::MSSQL; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/mysql.pm000644 000765 000024 00000003071 14124315137 022154 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::mysql; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/Oracle.pm000644 000765 000024 00000003651 14124315137 022220 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::Oracle; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/Pg.pm000644 000765 000024 00000002543 14124315137 021360 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::Pg; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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.57/lib/DBIx/Connector/Driver/SQLite.pm000644 000765 000024 00000003240 14124315137 022146 0ustar00apstaff000000 000000 use strict; use warnings; package DBIx::Connector::Driver::SQLite; use DBIx::Connector::Driver; our $VERSION = '0.57'; 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