DBD-Multi-1.02000755002011000024 013234704320 12665 5ustar00wrightstaff000000000000DBD-Multi-1.02/Build.PL000444002011000024 533213234704320 14321 0ustar00wrightstaff000000000000use v5.8; use strict; use warnings; use Module::Build; my $builder = Module::Build->new( module_name => 'DBD::Multi', license => 'perl_5', dist_author => q{Dan Wright }, dist_version_from => 'lib/DBD/Multi.pm', dist_abstract => 'Failover and Load Balancing of DBI Handles', release_status => 'stable', configure_requires => { 'Module::Build' => '0', }, build_requires => { 'Test::TCP' => '2.19', # Would not work for me with 2.13 'Test::More' => '0', 'Test::Pod' => '1.14', 'Test::Exception' => '0.21', 'DBD::SQLite' => '1.09', 'Pod::Simple' => '0', }, requires => { 'perl' => '5.008', 'Class::Accessor::Fast' => '0.19', 'Sys::SigAction' => '0.10', 'List::Util' => '1.18', 'DBI' => '0', }, add_to_cleanup => ['DBD-Multi-*'], meta_merge => { 'meta-spec' => { version => '2', url => 'https://metacpan.org/pod/CPAN::Meta::Spec', }, resources => { bugtracker => { web => 'https://github.com/dwright/DBD-Multi/issues', }, repository => { url => 'https://github.com/dwright/DBD-Multi.git', web => 'https://github.com/dwright/DBD-Multi', type => 'git', } }, }, ); $builder->create_build_script(); DBD-Multi-1.02/Changes000444002011000024 436613234704320 14326 0ustar00wrightstaff0000000000001.02 2018-02-01 - Regression test fix from Peter Pisar -- https://github.com/dwright/DBD-Multi/pull/3 - Removed Pod::Coverage test that wasn't being used anyway. 1.01 2017-08-31 - Huzzah! DBD::Multi has been an official DBD library recognized by DBI since December 2014. - Added public support for multi_do_all() - Replaced Module::Install with Module::Build. - Update meta information to point to github. - Update documentation. 0.18 2013-04-09 - Added get_info() patch from Jon Isbell (RT #84240) 0.17 2011-03-08 - New regression test verifying that previously failed databases are eventually re-tried. 0.16 2010-09-05 - No longer derived from DBD::File. Fixes compatability issues with DBI versions between 1.611_90 and 1.614. (RT #60193) 0.15 2010-07-15 - Catch error when a coderef datasource fails to connect to the database properly. Thanks to NCLEATON (RT #58769) 0.14 2008-03-03 - Updated required perl version from 5.5.0 to 5.8.0 after receiving reports of core dumps under 5.6.2 from cpantesters. Tried to diagnose the problem but didn't really get anywhere. 0.13 2008-02-20 - Added support for DBI_AUTOPROXY environment variable. Suggested by Tim Bunce. (RT #30250) 0.12 2007-08-28 - Added dependency listing for DBI to the Makefile to try and satisfy cpan testers. - Added dependency listing for DBD::SQLite, required for regression tests. 0.11 2007-07-25 - When two DSN's had the same priority, Multi was always attempting the first one in the list first rather than picking one randomly. This has been corrected. - Don't make a connection to every DB just to call disconnect(). 0.10 2007-07-05 - Added 'timeout' configuration parameter to keep connections from hanging forever. - Added support for coderef connect option from Mark Stosberg (RT #24400) - Added lazy-load.t regression test from Mark Stosberg (RT #24399) - Updated pod based on suggestions from Mark Stosberg (RT #24399) 0.03 2007-01-08 - Regression tests to verify random selection works, submitted by MARKSTOS@cpan.org 0.02 2006-06-21 - Cleaned up documentation a little. - Fixed some regression tests. 0.01 2005-04-10 - Initial version. DBD-Multi-1.02/MANIFEST000444002011000024 46113234704320 14134 0ustar00wrightstaff000000000000Build.PL Changes lib/DBD/Multi.pm MANIFEST This list of files META.json META.yml README.md t/00-load.t t/dbd-multi-db.t t/dbd-multi-dr.t t/dbd-multi-multi.t t/dbd-multi-st.t t/dbd-multi.t t/get_info.t t/handle-as-coderef.t t/lazy-load.t t/pod.t t/purge_failures.t t/random.t t/unavailable-server.t TODO DBD-Multi-1.02/META.json000444002011000024 363313234704320 14450 0ustar00wrightstaff000000000000{ "abstract" : "Failover and Load Balancing of DBI Handles", "author" : [ "Dan Wright " ], "dynamic_config" : 1, "generated_by" : "Module::Build version 0.4224", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "DBD-Multi", "prereqs" : { "build" : { "requires" : { "DBD::SQLite" : "1.09", "Pod::Simple" : "0", "Test::Exception" : "0.21", "Test::More" : "0", "Test::Pod" : "1.14", "Test::TCP" : "2.19" } }, "configure" : { "requires" : { "Module::Build" : "0" } }, "runtime" : { "requires" : { "Class::Accessor::Fast" : "0.19", "DBI" : "0", "List::Util" : "1.18", "Sys::SigAction" : "0.10", "perl" : "5.008" } } }, "provides" : { "DBD::Multi" : { "file" : "lib/DBD/Multi.pm", "version" : "1.02" }, "DBD::Multi::Handler" : { "file" : "lib/DBD/Multi.pm", "version" : "1.02" }, "DBD::Multi::db" : { "file" : "lib/DBD/Multi.pm", "version" : "1.02" }, "DBD::Multi::dr" : { "file" : "lib/DBD/Multi.pm", "version" : "1.02" }, "DBD::Multi::st" : { "file" : "lib/DBD/Multi.pm", "version" : "1.02" } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/dwright/DBD-Multi/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/dwright/DBD-Multi.git", "web" : "https://github.com/dwright/DBD-Multi" } }, "version" : "1.02", "x_serialization_backend" : "JSON::PP version 2.27300" } DBD-Multi-1.02/META.yml000444002011000024 220513234704320 14272 0ustar00wrightstaff000000000000--- abstract: 'Failover and Load Balancing of DBI Handles' author: - 'Dan Wright ' build_requires: DBD::SQLite: '1.09' Pod::Simple: '0' Test::Exception: '0.21' Test::More: '0' Test::Pod: '1.14' Test::TCP: '2.19' configure_requires: Module::Build: '0' dynamic_config: 1 generated_by: 'Module::Build version 0.4224, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: DBD-Multi provides: DBD::Multi: file: lib/DBD/Multi.pm version: '1.02' DBD::Multi::Handler: file: lib/DBD/Multi.pm version: '1.02' DBD::Multi::db: file: lib/DBD/Multi.pm version: '1.02' DBD::Multi::dr: file: lib/DBD/Multi.pm version: '1.02' DBD::Multi::st: file: lib/DBD/Multi.pm version: '1.02' requires: Class::Accessor::Fast: '0.19' DBI: '0' List::Util: '1.18' Sys::SigAction: '0.10' perl: '5.008' resources: bugtracker: https://github.com/dwright/DBD-Multi/issues repository: https://github.com/dwright/DBD-Multi.git version: '1.02' x_serialization_backend: 'CPAN::Meta::YAML version 0.018' DBD-Multi-1.02/README.md000444002011000024 415213234704320 14303 0ustar00wrightstaff000000000000NAME DBD::Multi - Manage Multiple Data Sources with Failover and Load Balancing SYNOPSIS use DBI; my $dbh = DBI->connect( 'dbi:Multi:', undef, undef, { dsns => [ # in priority order 10 => [ 'dbi:SQLite:read_one.db', '', '' ], 10 => [ 'dbi:SQLite:read_two.db', '', '' ], 20 => [ 'dbi:SQLite:master.db', '', '' ], ], # optional failed_max => 1, # short credibility failed_expire => 60*60, # long memory }); DESCRIPTION This software manages multiple database connections for the purposes of load balancing and simple failover procedures. It acts as a proxy between your code and your available databases. Although there is some code intended for read/write operations, this should be considered EXPIREMENTAL. This module is primary intended for read-only operations (where some other application is being used to handle replication). The interface is nearly the same as other DBI drivers with one notable exception. Configuring DSNs Specify an attribute to the "connect()" constructor, "dsns". This is a list of DSNs to configure. The configuration is given in pairs. First comes the priority of the DSN, lowest is tried first. Second is the DSN. The second parameter can either be a DBI object or a list of parameters to pass to the DBI "connect()" instructor. Configuring Failures By default a data source will not be tried again after it has failed three times. After five minutes that failure status will be removed and the data source may be tried again for future requests. To change the maximum number of failures allowed before a data source is deemed failed, set the "failed_max" parameter. To change the amount of time we remember a data source as being failed, set the "failed_expire" parameter in seconds. SEE ALSO DBD::Multiplex, DBI, perl. AUTHOR Initially written by Casey West and Dan Wright for pair Networks, Inc. (www.pair.com) Maintained by Dan Wright for pair Networks, Inc. . DBD-Multi-1.02/TODO000444002011000024 20013234704320 13462 0ustar00wrightstaff000000000000- Cleanup Code - Add a method for executing a block for every data source. - Add a method for dynamic addition of data sources. DBD-Multi-1.02/lib000755002011000024 013234704320 13433 5ustar00wrightstaff000000000000DBD-Multi-1.02/lib/DBD000755002011000024 013234704320 14024 5ustar00wrightstaff000000000000DBD-Multi-1.02/lib/DBD/Multi.pm000444002011000024 4707413234704320 15645 0ustar00wrightstaff000000000000package DBD::Multi; our $VERSION = '1.02'; package DBD::Multi::dr; our $VERSION = '1.02'; package DBD::Multi::db; our $VERSION = '1.02'; package DBD::Multi::st; our $VERSION = '1.02'; package DBD::Multi::Handler; our $VERSION = '1.02'; package DBD::Multi; use strict; use DBI; DBI->setup_driver('DBD::Multi'); use vars qw[$err $errstr $sqlstate $drh]; $err = 0; # DBI::err $errstr = ""; # DBI::errstr $sqlstate = ""; # DBI::state $drh = undef; sub driver { return $drh if $drh; my($class, $attr) = @_; $class .= '::dr'; $drh = DBI::_new_drh($class, { Name => 'Multi', Version => $VERSION, Err => \$DBD::Multi::err, Errstr => \$DBD::Multi::errstr, State => \$DBD::Multi::sqlstate, Attribution => 'DBD::Multi, pair Networks Inc.', }); DBD::Multi::db->install_method('multi_do_all'); return $drh; } ####################################################################### package DBD::Multi::dr; use strict; $DBD::Multi::dr::imp_data_size = 0; use DBD::File; sub DESTROY { shift->STORE(Active => 0) } sub connect { my($drh, $dbname, $user, $auth, $attr) = @_; my $dbh = DBI::_new_dbh( $drh => { Name => $dbname, USER => $user, CURRENT_USER => $user, }, ); my @dsns = $attr->{dsns} && ref($attr->{dsns}) eq 'ARRAY' ? @{$attr->{dsns}} : (); if ( $dbname =~ /dsn=(.*)/ ) { push @dsns, ( -1, [$1, $user, $auth] ); } my $handler = DBD::Multi::Handler->new({ dsources => [ @dsns ], }); $handler->failed_max($attr->{failed_max}) if exists $attr->{failed_max}; $handler->failed_expire($attr->{failed_expire}) if exists $attr->{failed_expire}; $dbh->STORE(_handler => $handler); $dbh->STORE(handler => $handler); # temporary $drh->{_handler} = $handler; $dbh->STORE(Active => 1); return $dbh; } sub data_sources { shift->FETCH('_handler')->all_sources } ####################################################################### package DBD::Multi::db; use strict; $DBD::Multi::db::imp_data_size = 0; sub prepare { my ($dbh, $statement, @attribs) = @_; # create a 'blank' sth my ($outer, $sth) = DBI::_new_sth($dbh, { Statement => $statement }); my $handler = $dbh->FETCH('_handler'); $sth->STORE(_handler => $handler); my $_dbh = $handler->dbh; my $_sth; until ( $_sth ) { $_sth = $_dbh->prepare($statement, @attribs); unless ( $_sth ) { $handler->dbh_failed; $_dbh = $handler->dbh; } } $sth->STORE(NUM_OF_PARAMS => $_sth->FETCH('NUM_OF_PARAMS')); $sth->STORE(_dbh => $_dbh); $sth->STORE(_sth => $_sth); return $outer; } sub multi_do_all { my $dbh = shift; my $handler = $dbh->FETCH('_handler'); return $handler->multi_do_all( @_ ); } sub disconnect { my ($dbh) = @_; $dbh->STORE(Active => 0); 1; } sub commit { my ($dbh) = @_; if ( $dbh->FETCH('Active') ) { return $dbh->FETCH('_dbh')->commit if $dbh->FETCH('_dbh'); } return; } sub rollback { my ($dbh) = @_; if ( $dbh->FETCH('Active') ) { return $dbh->FETCH('_dbh')->rollback if $dbh->FETCH('_dbh'); } return; } sub get_info { my($dbh, $info_type) = @_; # return info from current connection my $handler = $dbh->FETCH('_handler'); my $_dbh = $handler->dbh; return $_dbh->get_info($info_type); } sub STORE { my ($self, $attr, $val) = @_; $self->{$attr} = $val; } sub DESTROY { shift->disconnect } ####################################################################### package DBD::Multi::st; use strict; $DBD::Multi::st::imp_data_size = 0; use vars qw[@METHODS @FIELDS]; @METHODS = qw[ bind_param bind_param_inout bind_param_array execute_array execute_for_fetch fetch fetchrow_arrayref fetchrow_array fetchrow_hashref fetchall_arrayref fetchall_hashref bind_col bind_columns dump_results ]; @FIELDS = qw[ NUM_OF_FIELDS CursorName ParamValues RowsInCache ]; sub execute { my $sth = shift; my $_sth = $sth->FETCH('_sth'); my $params = @_ ? $sth->{f_params} = [ @_ ] : $sth->{f_params}; $sth->finish if $sth->FETCH('Active'); $sth->{Active} = 1; my $rc = $_sth->execute(@{$params}); for my $field ( @FIELDS ) { my $value = $_sth->FETCH($field); $sth->STORE($field => $value) unless ! defined $value || defined $sth->FETCH($field); } return $rc; } sub FETCH { my ($sth, $attrib) = @_; $sth->{'_sth'}->FETCH($attrib) || $sth->{$attrib}; } sub STORE { my ($self, $attr, $val) = @_; $self->{$attr} = $val; } sub rows { shift->FETCH('_sth')->rows } sub finish { my ($sth) = @_; $sth->STORE(Active => 0); return $sth->FETCH('_sth')->finish; } foreach my $method ( @METHODS ) { no strict; *{$method} = sub { shift->FETCH('_sth')->$method(@_) }; } ####################################################################### package DBD::Multi::Handler; use strict; use base qw[Class::Accessor::Fast]; use Sys::SigAction qw(timeout_call); use List::Util qw(shuffle); =begin ImplementationNotes dsources - This thing changes from an arrayref to a hashref during construction. :( Initially, when data is passed in during construction, it's an arrayref containing the 'dsns' param from the user's connect() call. Later, when _configure_dsources gets called, it turns into a multi-dimension hashref: $dsources->{$pri}->{$dsource_id} = 1; The first key is the priority number, the second key is the data source index number. The value is always just a true value. nextid - A counter. Stores the index number of the next data source to be added. all_dsources - A hashref. Maps index number to the connect data. current_dsource - The most recent chosen datasource index number. used - A hashref. Keys are index numbers. Values are true when the datasource has been previously assigned and we want to prefer other datasources of the same priority (for round-robin load distribution). failed - A hashref. Keys are index numbers. Values are counters indicating how many times the data source has failed. failed_last - A hashref. Keys are index number. Values are unix timestamp indicating the most recent time a data source failed. failed_max - A scalar value. Number of times a datasource may fail before we stop trying it. failed_expire - A scalar value. Number of seconds since we stopped trying a datasource before we'll try it again. timeout - A scalar value. Number of seconds we try to connect to a datasource before giving up. =end ImplementationNotes =cut __PACKAGE__->mk_accessors(qw[ dsources nextid all_dsources current_dsource used failed failed_last failed_max failed_expire timeout ]); sub new { my ($class, $args) = @_; my $self = $class->SUPER::new($args); $self->nextid(0) unless defined $self->nextid; $self->all_dsources({}); $self->used({}); $self->failed({}); $self->failed_last({}); $self->failed_max(3) unless defined $self->failed_max; $self->failed_expire(60*5) unless defined $self->failed_expire; $self->timeout( 5 ) unless defined $self->timeout; $self->_configure_dsources; return $self; } sub all_sources { my ($self) = @_; return values %{$self->all_dsources}; } sub add_to_pri { my ($self, $pri, $dsource) = @_; my $dsource_id = $self->nextid; my $dsources = $self->dsources; my $all = $self->all_dsources; $all->{$dsource_id} = $dsource; $dsources->{$pri}->{$dsource_id} = 1; $self->nextid($dsource_id + 1); } sub dbh { my $self = shift; my $dbh = $self->_connect_dsource; return $dbh if $dbh; $self->dbh_failed; $self->dbh; } sub dbh_failed { my ($self) = @_; my $current_dsource = $self->current_dsource; $self->failed->{$current_dsource}++; $self->failed_last->{$current_dsource} = time; } sub _purge_old_failures { my ($self) = @_; my $now = time; my @all = keys %{$self->all_dsources}; foreach my $dsource ( @all ) { next unless $self->failed->{$dsource}; if ( ($now - $self->failed_last->{$dsource}) > $self->failed_expire ) { delete $self->failed->{$dsource}; delete $self->failed_last->{$dsource}; } } } sub _pick_dsource { my ($self) = @_; $self->_purge_old_failures; my $dsources = $self->dsources; my @pri = sort { $a <=> $b } keys %{$dsources}; foreach my $pri ( @pri ) { my $dsource = $self->_pick_pri_dsource($dsources->{$pri}); if ( defined $dsource ) { $self->current_dsource($dsource); return; } } $self->used({}); return $self->_pick_dsource if (grep {$self->failed->{$_} >= $self->failed_max} keys(%{$self->failed})) < keys(%{$self->all_dsources}); die("All data sources failed!"); } ### _pick_pri_dsource # Given a list of data sources, all of the same priority, choose one to use. # Passed in a structure like this: # _pick_pri_dsource( $self, { 3 => 1, 4 => 1, 5 => 1 } ) # Where the keys 3,4,5 are dsource id's, and the values are always true. sub _pick_pri_dsource { my ($self, $dsources) = @_; my @dsources = sort { $a <=> $b } keys %{$dsources}; # Indexes of data sources to try. my @used = grep { exists $self->used->{$_} } @dsources; # List of data sources already used. my @failed = grep { exists($self->failed->{$_}) && $self->failed->{$_} >= $self->failed_max } @dsources; # List of data sources that won't be tried. # We've used them all and they all failed. Escallate. return if @used == @dsources && @failed == @dsources; # We've used them all but some are good. Purge and reuse. delete @{$self->used}{@dsources} if @used == @dsources; foreach my $dsource ( shuffle @dsources ) { next if $self->failed->{$dsource} && $self->failed->{$dsource} >= $self->failed_max; next if $self->used->{$dsource}; $self->used->{$dsource} = 1; return $dsource; } return; } sub _configure_dsources { my ($self) = @_; my $dsources = $self->dsources; $self->dsources({}); while ( my $pri = shift @{$dsources} ) { my $dsource = shift @{$dsources} or last; $self->add_to_pri($pri => $dsource); } } sub _connect_dsource { my ($self, $dsource) = @_; unless ( $dsource ) { $self->_pick_dsource; $dsource = $self->all_dsources->{$self->current_dsource}; } # Support ready-made handles return $dsource if UNIVERSAL::isa($dsource, 'DBI::db'); # Support code-refs which return handles if (ref $dsource eq 'CODE') { my $handle = $dsource->(); return $handle if UNIVERSAL::isa($handle, 'DBI::db'); return undef; # Connect by coderef failed. } my $dbh; local $ENV{DBI_AUTOPROXY}; if (timeout_call( $self->timeout, sub { $dbh = DBI->connect_cached(@{$dsource}) } )) { #warn "Timeout[", $self->current_dsource, "] at ", time, "\n"; } return $dbh; } sub connect_dsource { my ($self, $dsource) = @_; $self->_connect_dsource($dsource); } sub multi_do_all { my ($self, $code) = @_; my @all = values %{$self->all_dsources}; foreach my $source ( @all ) { my $dbh = $self->connect_dsource($source); next unless $dbh; if ( $dbh->{handler} ) { $dbh->{handler}->multi_do_all($code, $source); next; } $code->($dbh); } } 1; __END__ =head1 NAME DBD::Multi - Manage Multiple Data Sources with Failover and Load Balancing =head1 SYNOPSIS use DBI; my $other_dbh = DBI->connect(...); my $dbh = DBI->connect( 'dbi:Multi:', undef, undef, { dsns => [ # in priority order 10 => [ 'dbi:SQLite:read_one.db', '', '' ], 10 => [ 'dbi:SQLite:read_two.db', '', '' ], 20 => [ 'dbi:SQLite:master.db', '', '' ], 30 => $other_dbh, 40 => sub { DBI->connect }, ], # optional failed_max => 1, # short credibility failed_expire => 60*60, # long memory timeout => 10, # time out connection attempts after 10 seconds. }); $dbh->prepare(...); # Works like any other DBI handle. $dbh->multi_do_all( # Loops through every single DB handle. sub { my $dbh = shift; ... } ); =head1 DESCRIPTION This software manages multiple database connections for failovers and also simple load balancing. It acts as a proxy between your code and your database connections, transparently choosing a connection for each query, based on your preferences and present availability of the DB server. This module is intended for read-only operations (where some other application is being used to handle replication). This software does not prevent write operations from being executed. This is left up to the user. See L below for ideas. The interface is nearly the same as other DBI drivers except that it allows you to specify multiple connections for a single handle. =head1 CONFIGURING CONNECTIONS =head2 Configuring DSNs Specify an attribute to the C constructor, C. This is a list of DSNs to configure. The configuration is given in pairs. First comes the priority of the DSN. Second is the DSN. The priorities specify which connections should be used first (lowest to highest). As long as the lowest priority connection is responding, the higher priority connections will never be used. If multiple connections have the same priority, then one connection will be chosen randomly for each operation. Note that the random DB is chosen when the statement is prepared. Therefore executing multiple queries on the same prepared statement handle will always run on the same connection. The second parameter can a DBI object, a code ref which returns a DBI object, or a list of parameters to pass to the DBI C instructor. If a set of parameters or a code ref is given, then DBD::Multi will be able to attempt re-connect in the event that the connection is lost. If a DBI object is used, the DBD::Multi will give up permanently once that connection is lost. These connections are lazy loaded, meaning they aren't made until they are actually used. =head2 Configuring Failures By default, after a data source fails three times, it will not be tried again for 5 minutes. After that period, the data source will be tried again for future requests until it reaches its three failure limit (the cycle repeats forever). To change the maximum number of failures allowed before a data source is deemed failed, set the C parameter. To change the amount of time we remember a data source as being failed, set the C parameter in seconds. =head2 Timing out connections. By default, if you attempt to connect to an IP that isn't answering, DBI will hang for a very long period of time. This behavior is not desirable in a multi database setup. Instead, it is better to give up on slow connections and move on to other databases quickly. DBD::Multi will give up on connection attempts after 5 seconds and then try another connection. You may set the C parameter to change the timeout time, or set it to 0 to disable the timeout feature completely. =head1 EXTRA METHODS =head2 multi_do_all Loops through every database handle, executing an arbitrary coderef passing the current database handle as the first parameter and the original connection parameters as the second parameter. If a database is unreachable, multi_do_all will skip over it. use Data::Dumper; my $expected_value = ...; $dbh->multi_do_all( sub { my $dbh = shift; my $source = shift; my($value) = $dbh->selectrow_array("SELECT ..."); unless ( $value eq $expected_value ) { die "Unexpected value, $value found. (Expected $expected_value). Data Source:\n", Dumper( $source ); } } ); =head1 SUGGESTED USES Here are some ideas on how to use this module effectively and safely. It is important to remember that C is not intended for read-write operations. One suggestion to prevent accidental write operations is to make sure that the user you are connecting to the databases with has privileges sufficiently restricted to prevent updates. Read-write operations should happen through a separate database handle that will somehow trigger replication to all of your databases. For example, your read-write handle might be connected to the master server that replicates itself to all of the subordinate servers. Read-only database calls within your application would be updated to explicitly use the read-only (DBD::Multi) handle. It is not necessary to find every single call that can be load balanced, since they can safely be sent through the read/write handle as well. =head1 TODO There really isn't much of a TODO list for this module at this time. Feel free to submit a bug report to L if you think there is a feature missing. Although there is some code intended for read/write operations, this should be considered not supported and not actively developed at this time. The actual read/write code remains un-documented because in the event that I ever do decide to work on supporting read/write operations, the API is not guaranteed to stay the same. The focus of this module is presently limited to read-only operations. =head1 TESTING DBD::Multi has it's own suite of regression tests. But, suppose you want to verify that you can slip DBD::Multi into whatever application you already have written without breaking anything. Thanks to a feature of DBI, you can regression test DBD::Multi using any existing tests that already use DBI without having to update any of your code. Simply set the environment variable DBI_AUTOPROXY to 'dbi:Multi:' and then run your tests. DBD::Multi should act as a silent pipe between your application and whatever database driver you were previously using. This will help you verify that you aren't currently using some feature of the DBI that breaks DBD::Multi (If you are, please do me a favor and submit a bug report so I can fix it). =head1 SEE ALSO There are other modules that have similar, but different objectives. Depending on your specific needs these may be more or less suitable for your task: =over =item L A plugin for the L framework which makes it easy to support two database handles, and also supports lazy-loading. =item L The original inspiration for this module. It doesn't support as many connection configurations options at this module. It does try to support write options in a single master, mutliple slave configuration. It does this by parsing your SQL and trying to decide if you were doing a read or write operation. =item L Written after this module. Built for high availability rather than load balancing. It purposely ignores some DBI features in favor of producing the fastest results for the most common operations. It doesn't utilize the standard DBI->connect() API, which means it will not work as a drop-in auto proxy. =back L, L - You should probably already know about these before using this module. =head1 AUTHOR Initially written by Casey West and Dan Wright for pair Networks, Inc. (www.pair.com) Maintained by Dan Wright. >. =cut DBD-Multi-1.02/t000755002011000024 013234704320 13130 5ustar00wrightstaff000000000000DBD-Multi-1.02/t/00-load.t000444002011000024 21413234704320 14563 0ustar00wrightstaff000000000000#!perl -T use Test::More tests => 1; BEGIN { use_ok( 'DBD::Multi' ); } diag( "Testing DBD::Multi $DBD::Multi::VERSION, Perl $], $^X" ); DBD-Multi-1.02/t/dbd-multi-db.t000444002011000024 170113234704320 15715 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More tests => 7; # $Id: dbd-multi-db.t,v 1.3 2006/02/10 18:47:47 wright Exp $ use strict; $^W = 1; use_ok 'DBD::Multi'; can_ok 'DBD::Multi::db', 'prepare'; cleanup(); my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:one.db', '',''], 1 => DBI->connect('DBI:SQLite:two.db'), 2 => ['dbi:SQLite:three.db','',''], 2 => DBI->connect('DBI:SQLite:four.db'), ], }); isa_ok $c, 'DBI::db'; cmp_ok scalar($c->data_sources), '==', 4, "data_sources returned some"; # one my $sth = $c->prepare("CREATE TABLE multi(id int)"); isa_ok $sth, 'DBI::st'; # two is $c->do("CREATE TABLE multi(id int)"), '0E0', 'do successful'; $SIG{__WARN__} = sub {}; # I don't want to hear it. eval { my $sth = $c->prepare("CREAATE TABLE multi(id int)"); }; ok $@, "$@"; cleanup(); sub cleanup { -e "$_.db" and unlink "$_.db" for qw[one two three four five six seven eight nine ten]; } DBD-Multi-1.02/t/dbd-multi-dr.t000444002011000024 105613234704320 15740 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More tests => 5; # $Id: dbd-multi-dr.t,v 1.2 2006/02/10 18:47:47 wright Exp $ use strict; $^W = 1; use_ok 'DBD::Multi'; can_ok 'DBD::Multi::dr', 'connect'; isa_ok DBI->connect('DBI:Multi:'), 'DBI::db'; my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:one.db'], 2 => DBI->connect('DBI:SQLite:two.db'), ], }); isa_ok $c, 'DBI::db'; cmp_ok scalar($c->data_sources), '>=', 1, "data_sources returned some"; unlink "$_.db" for qw[one two three four five six seven eight nine ten]; DBD-Multi-1.02/t/dbd-multi-multi.t000444002011000024 342313234704320 16465 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More tests => 88; # $Id: dbd-multi-multi.t,v 1.4 2006/02/10 18:47:47 wright Exp $ use strict; $^W = 1; use_ok 'DBD::Multi'; my $child_one = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:one.db', '',''], 2 => DBI->connect('DBI:SQLite:two.db'), 3 => ['dbi:SQLite:three.db','',''], 4 => DBI->connect('DBI:SQLite:four.db'), ], }); my $child_two = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:five.db', '',''], 2 => DBI->connect('DBI:SQLite:six.db'), 3 => ['dbi:SQLite:seven.db','',''], 4 => DBI->connect('DBI:SQLite:eight.db'), ], }); my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:nine.db', '',''], 2 => $child_one, 3 => $child_two, 4 => ['dbi:SQLite:ten.db', '',''], ], }); isa_ok $child_one, 'DBI::db'; isa_ok $child_two, 'DBI::db'; isa_ok $c, 'DBI::db'; is $child_one->data_sources, 4, 'four data sources'; is $child_two->data_sources, 4, 'four data sources'; is $c->data_sources, 4, 'four data sources'; sub do_on_all { my $dbh = shift; my @args = @_; my $i = 1; $c->multi_do_all(sub {ok shift->do(@args), "$i: @args"; $i++}); } do_on_all($c, "CREATE TABLE multi(id int)"); do_on_all($c, "INSERT INTO multi VALUES(?)", {}, $_) for 1..5; for my $val ( 1 .. 5 ) { my $sth = $c->prepare("SELECT * FROM multi where id = ?"); isa_ok $sth, 'DBI::st'; ok $sth->execute($val), 'executed'; my $hash = $sth->fetchall_hashref('id'); is scalar(keys %{$hash}), 1, 'just one'; is $hash->{$val}->{id}, $val, 'hash structure correct'; } ok $c->disconnect, "Disconnected."; unlink "$_.db" for qw[one two three four five six seven eight nine ten]; DBD-Multi-1.02/t/dbd-multi-st.t000444002011000024 265513234704320 15767 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More tests => 41; # $Id: dbd-multi-st.t,v 1.3 2006/02/10 18:47:47 wright Exp $ use strict; $^W = 1; use_ok 'DBD::Multi'; can_ok 'DBD::Multi::st', 'execute', 'rows'; my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:one.db', '',''], 1 => DBI->connect('DBI:SQLite:two.db'), 2 => ['dbi:SQLite:three.db','',''], 3 => DBI->connect('DBI:SQLite:four.db'), ], }); isa_ok $c, 'DBI::db'; $c->multi_do_all(sub { my $dbh = shift; is $dbh->do("CREATE TABLE multi(id int)"), '0E0', 'do create successful'; }); $c->multi_do_all(sub { my $dbh = shift; is($dbh->do("INSERT INTO multi VALUES($_)"), 1, 'insert via do works') for 1..4; }); $c->multi_do_all(sub { my $dbh = shift; my $sth = $dbh->prepare("INSERT INTO multi VALUES(?)"); isa_ok $sth, 'DBI::st'; is($sth->execute($_), 1, 'insert via prepare/execute works') for 5..6; }); my $sth = $c->prepare("SELECT * FROM multi"); isa_ok $sth, 'DBI::st'; use Data::Dumper; is $sth->execute, '0E0', 'executed select'; my $all_arrayref = $sth->fetchall_arrayref; is scalar(@{$all_arrayref}), 6, 'six records returned'; is $sth->execute, '0E0', 'executed select'; my $all_hashref = $sth->fetchall_hashref('id'); is scalar(keys %{$all_hashref}), 6, 'six records returned'; is $sth->finish, 1, 'finished'; unlink "$_.db" for qw[one two three four five six seven eight nine ten]; DBD-Multi-1.02/t/dbd-multi.t000444002011000024 32413234704320 15312 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More tests => 3; # $Id: dbd-multi.t,v 1.2 2006/02/10 18:47:47 wright Exp $ use strict; $^W = 1; use_ok 'DBD::Multi'; can_ok 'DBD::Multi', 'driver'; isa_ok DBD::Multi->driver, 'DBI::dr'; DBD-Multi-1.02/t/get_info.t000444002011000024 120613234704320 15243 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More 'no_plan'; use strict; $^W = 1; # Test that two dbs with the same priority are actually randomly selected. use DBI; use DBD::SQLite; use DBD::Multi; use Data::Dumper; use DBI::Const::GetInfoType; my $dbh_1 = DBI->connect("dbi:SQLite:one.db"); my $multi = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => $dbh_1 ] } ); foreach my $i ( qw( SQL_DBMS_NAME SQL_DBMS_VER SQL_IDENTIFIER_QUOTE_CHAR SQL_CATALOG_NAME_SEPARATOR SQL_CATALOG_LOCATION ) ) { my $type = $GetInfoType{$i}; is ( $dbh_1->get_info($type), $multi->get_info($type), "Compare $i info." ); } $multi->disconnect(); unlink "one.db"; DBD-Multi-1.02/t/handle-as-coderef.t000444002011000024 237713234704320 16724 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More 'no_plan'; # $Id: handle-as-coderef.t,v 1.2 2010/07/16 00:12:58 wright Exp $ use strict; $^W = 1; use_ok 'DBD::Multi'; can_ok 'DBD::Multi::db', 'prepare'; my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:one.db', '',''], 1 => sub { DBI->connect('DBI:SQLite:two.db') }, 2 => ['dbi:SQLite:three.db','',''], 2 => sub { DBI->connect('DBI:SQLite:four.db') }, ], }); isa_ok $c, 'DBI::db'; cmp_ok scalar($c->data_sources), '==', 4, "data_sources returned some"; # one my $sth = $c->prepare("CREATE TABLE multi(id int)"); isa_ok $sth, 'DBI::st'; # two is $c->do("CREATE TABLE multi(id int)"), '0E0', 'do successful'; { local $SIG{__WARN__} = sub { }; # I don't want to hear it. eval { my $sth = $c->prepare("CREAATE TABLE multi(id int)"); }; ok $@, "Syntax errror: $@"; } $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => sub { return undef }, 2 => ['dbi:SQLite:one.db', '',''], ], }); # CPAN Ticket 58769 my $sth2 = $c->prepare("CREATE TABLE multi2(id int)"); isa_ok $sth2, 'DBI::st'; is $c->do("CREATE TABLE multi2(id int)"), '0E0', 'do successful'; unlink "$_.db" for qw[one two three four five six seven eight nine ten]; DBD-Multi-1.02/t/lazy-load.t000444002011000024 102113234704320 15340 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More 'no_plan'; use Test::Exception; # Test that the handles are lazy-loaded. use strict; $^W = 1; use DBI; my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:Boom', '',''], ], }); isa_ok $c, 'DBI::db', "invalid connect strict survives DBD::Multi connect()"; dies_ok { $c->prepare("CREATE TABLE multi(id int)") } "invalid connect string blows up when handle is actually attempted to be used"; lives_ok { $c->disconnect } "Don't connect just to disconnect"; DBD-Multi-1.02/t/pod.t000444002011000024 22113234704320 14207 0ustar00wrightstaff000000000000#!perl -T use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD - $@" if $@; all_pod_files_ok(); DBD-Multi-1.02/t/purge_failures.t000444002011000024 326413234704320 16473 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More 'no_plan'; use strict; $^W = 1; # Test that failing dbs are eventually re-tried. use DBI; use DBD::SQLite; use DBD::Multi; my %SOURCE = ( 1 => "dbi:SQLite:one.db", 2 => "dbi:SQLite:two.db" ); my $WORKING = 0; init(); my $c = db_connect(); my @count = (undef,0,0); for (1..100) { my $val = $c->selectrow_array("SELECT id FROM multi"); $count[$val]++; } is($count[1], 0, "first db returned no values because it had crashed." ); is($count[2], 100, "second db used for every query." ); @count = (undef,0,0); $WORKING = 1; sleep( 3 ); for (1..100) { my $val = $c->selectrow_array("SELECT id FROM multi"); $count[$val]++; } is($count[1], 100, "first db used every time due to higher priority." ); is($count[2], 0, "second db unused because first db was available." ); unlink "$_.db" for qw[one two]; sub init { unlink "$_.db" for qw[one two]; # Set up the first DB with a value of 1 my $dbh_1 = DBI->connect($SOURCE{1}); is $dbh_1->do("CREATE TABLE multi(id int)"), '0E0', 'do create successful'; is($dbh_1->do("INSERT INTO multi VALUES(1)"), 1, 'insert via do works'); # And the second DB with the value of 2 $dbh_1 = DBI->connect($SOURCE{2}); is $dbh_1->do("CREATE TABLE multi(id int)"), '0E0', 'do create successful'; is($dbh_1->do("INSERT INTO multi VALUES(2)"), 1, 'insert via do works'); } sub db_connect { my $first = sub { $WORKING ? DBI->connect($SOURCE{1}) : undef }; my $second = sub { DBI->connect($SOURCE{2}) }; return DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => $first, 2 => $second, ], failed_expire => 2, }); } DBD-Multi-1.02/t/random.t000444002011000024 325313234704320 14735 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More 'no_plan'; use strict; $^W = 1; # Test that two dbs with the same priority are actually randomly selected. use DBI; use DBD::SQLite; use DBD::Multi; init(); my $c = db_connect(); my @count = (undef,0,0); my ($one_cnt,$two_cnt) = (0,0); for (1..100) { my $val = $c->selectrow_array("SELECT id FROM multi"); $count[$val]++; } ok($count[1], "first db with same priority was selected through random process ($count[1]/100)"); ok($count[2], "second db with same priority was selected through random process ($count[2]/100)"); @count = (undef,0,0); for (1..100) { my $c = db_connect(); my $val = $c->selectrow_array("SELECT id FROM multi"); $count[$val]++; } ok($count[1], "first db with same priority was selected through random process on initial connect ($count[1]/100)"); ok($count[2], "second db with same priority was selected through random process on initial connect ($count[2]/100)"); unlink "$_.db" for qw[one two]; sub init { # Set up the first DB with a value of 1 my $dbh_1 = DBI->connect("dbi:SQLite:one.db"); is $dbh_1->do("CREATE TABLE multi(id int)"), '0E0', 'do create successful'; is($dbh_1->do("INSERT INTO multi VALUES(1)"), 1, 'insert via do works'); # And the second DB with the value of 2 $dbh_1 = DBI->connect("dbi:SQLite:two.db"); is $dbh_1->do("CREATE TABLE multi(id int)"), '0E0', 'do create successful'; is($dbh_1->do("INSERT INTO multi VALUES(2)"), 1, 'insert via do works'); } sub db_connect { return DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => ['dbi:SQLite:one.db', '',''], 1 => ['dbi:SQLite:two.db','',''], ], }); } DBD-Multi-1.02/t/unavailable-server.t000444002011000024 437313234704320 17250 0ustar00wrightstaff000000000000# vim: ft=perl use Test::More; use strict; use warnings; use FindBin qw($Bin); if ( $Bin =~ /(.*)/ ) { $Bin = $1; } ## Test that failover happens when a server is unavailable. use DBI; use DBD::SQLite; use DBD::Multi; use Data::Dumper; use Sys::SigAction qw( timeout_call ); use Test::TCP (); eval { require DBD::Pg; }; if ( $@ ) { plan skip_all => 'DBD::Pg unavailable'; exit; } # Start a TCP server that will provide timing-out Pg server my $host = '127.0.0.1'; my $server = Test::TCP->new( listen => 1, host => $host, code => sub { while (1) { sleep 10; } } ); if (!$server) { plan skip_all => 'Could not start a TCP server'; exit; } plan tests => 7; pass 'DBD::Pg is installed'; my @PG_CONNECT = ('dbi:Pg:dbname=fake;host=' . $host . ';port=' . $server->port, 'fakeuser','fakepass') ; my $SQ_TABLE = "$Bin/one.db"; cleanup(); my @SQ_CONNECT = ("dbi:SQLite:$SQ_TABLE"); unlink( $SQ_TABLE ); # Set up the first DB with a value of 1 my $dbh_1 = DBI->connect( @SQ_CONNECT ); is $dbh_1->do("CREATE TABLE multi(id int)"), '0E0', 'do create successful'; is($dbh_1->do("INSERT INTO multi VALUES(1)"), 1, 'insert via do works'); ## Verify a normal connect attempt to the non-existant pg server fails: ok( timeout_call( 5, sub { my $ctest = DBI->connect(@PG_CONNECT); } ), 'Direct connection timed out' ); my $c = DBI->connect('DBI:Multi:', undef, undef, { dsns => [ 1 => \@PG_CONNECT, 50 => \@SQ_CONNECT, ], }); ok( !timeout_call( 0, sub{ sleep 2 } ), "Timeout 0 should never time out" ); diag "Pausing up to 10 seconds to test timeout..."; my $val; ok( # Note: Since DBD::Multi is using timeout_call, and since you can't nest #calls to timeout_call, the timeout period here is really irrelevant as long #as Multi is doing what it should. What's important is that a value is #eventually returned. The only reason timeout_call is used at all is in #case Multi turns out to be broken. !timeout_call( 10, sub { $val = $c->selectrow_array("SELECT id FROM multi") } ), "Value should have been returned" ); is($val, 1, "Query failed over to the second DB"); cleanup(); $server->stop(); sub cleanup { -e $SQ_TABLE and unlink( $SQ_TABLE ); }