File Coverage

blib/lib/DBIx/Introspector.pm

Criterion	Covered	Total	%
statement	43	55	78.1
branch	18	28	64.2
condition	7	11	63.6
subroutine	9	10	90.0
pod	5	5	100.0
total	82	109	75.2

package DBIx::Introspector;
$DBIx::Introspector::VERSION = '0.001004';
# ABSTRACT: Detect what database you are connected to

use Moo;
use DBIx::Introspector::Driver;

has _drivers => (
   is => 'ro',
   required => 1,
   init_arg => 'drivers',
   coerce => sub {
      return $_[0] if ref $_[0] eq 'ARRAY';
      return [ map DBIx::Introspector::Driver->new($_),
         {
            name => 'DBI',
            connected_determination_strategy => sub { $_[1]->{Driver}{Name} },
            unconnected_determination_strategy => sub {
               my $dsn = $_[1] || $ENV{DBI_DSN} || '';
               my ($driver) = $dsn =~ /dbi:([^:]+):/i;
               $driver ||= $ENV{DBI_DRIVER};
               return $driver
            },
         },
         { name => 'ACCESS',      parents => ['DBI'] },
         { name => 'DB2',         parents => ['DBI'] },
         { name => 'Informix',    parents => ['DBI'] },
         { name => 'InterBase',   parents => ['DBI'] },
         { name => 'MSSQL',       parents => ['DBI'] },
         { name => 'Oracle',      parents => ['DBI'] },
         { name => 'Pg',          parents => ['DBI'] },
         { name => 'SQLAnywhere', parents => ['DBI'] },
         { name => 'SQLite',      parents => ['DBI'] },
         { name => 'Sybase',      parents => ['DBI'] },
         { name => 'mysql',       parents => ['DBI'] },
         { name => 'Firebird::Common',    parents => ['Interbase'] },
         { name => 'Firebird',    parents => ['Interbase'] },
         {
            name => 'ODBC',
            connected_determination_strategy => sub {
               my $v = $_[0]->_get_info_from_dbh($_[1], 'SQL_DBMS_NAME');
               $v =~ s/\W/_/g;
               "ODBC_$v"
            },
            parents => ['DBI'],
         },
         { name => 'ODBC_ACCESS',               parents => ['ACCESS', 'ODBC'] },
         { name => 'ODBC_DB2_400_SQL',          parents => ['DB2', 'ODBC'] },
         { name => 'ODBC_Firebird',             parents => ['Firebird::Common', 'ODBC'] },
         { name => 'ODBC_Microsoft_SQL_Server', parents => ['MSSQL', 'ODBC'] },
         { name => 'ODBC_SQL_Anywhere',         parents => ['SQLAnywhere', 'ODBC'] },
         {
            name => 'ADO',
            connected_determination_strategy => sub {
               my $v = $_[0]->_get_info_from_dbh($_[1], 'SQL_DBMS_NAME');
               $v =~ s/\W/_/g;
               "ADO_$v"
            },
            parents => ['DBI'],
         },
         { name => 'ADO_MS_Jet',               parents => ['ACCESS', 'ADO'] },
         { name => 'ADO_Microsoft_SQL_Server', parents => ['MSSQL', 'ADO'] },
      ] if $_[0] eq '2013-12.01'
   },
);

sub _root_driver { shift->_drivers->[0] }

has _drivers_by_name => (
   is => 'ro',
   builder => sub { +{ map { $_->name => $_ } @{$_[0]->_drivers} } },
   clearer => '_clear_drivers_by_name',
   lazy => 1,
);

sub add_driver {
   my ($self, $driver) = @_;

   $self->_clear_drivers_by_name;
   # check for dupes?
   push @{$self->_drivers}, DBIx::Introspector::Driver->new($driver)
}

sub replace_driver {
   my ($self, $driver) = @_;

   $self->_clear_drivers_by_name;
   @{$self->_drivers} = (
      (grep $_ ne $driver->{name}, @{$self->_drivers}),
      DBIx::Introspector::Driver->new($driver)
   );
}

sub decorate_driver_unconnected {
   my ($self, $name, $key, $value) = @_;

   if (my $d = $self->_drivers_by_name->{$name}) {
      $d->_add_unconnected_option($key => $value)
   } else {
      die "no such driver <$name>"
   }
}

sub decorate_driver_connected {
   my ($self, $name, $key, $value) = @_;

   if (my $d = $self->_drivers_by_name->{$name}) {
      $d->_add_connected_option($key => $value)
   } else {
      die "no such driver <$name>"
   }
}

sub get {
   my ($self, $dbh, $dsn, $key, $opt) = @_;
   $opt ||= {};

   my @args = (
      drivers_by_name => $self->_drivers_by_name,
      key => $key
   );

   if ($dbh and my $driver = $self->_driver_for((ref $dbh eq 'CODE' ? $dbh->() : $dbh), $dsn)) {
      my $ret = $driver
         ->_get_when_connected({
            dbh => $dbh,
            dsn => $dsn,
            @args,
         });
      return $ret if defined $ret;
      $ret = $driver
         ->_get_when_unconnected({
            dsn => $dsn,
            @args,
         });
      return $ret if defined $ret;
   }

   my $dsn_ret = $self->_driver_for($dbh, $dsn)
      ->_get_when_unconnected({
         dsn => $dsn,
         @args,
      }) if $dsn;
   return $dsn_ret if defined $dsn_ret;

   if (ref $dbh eq 'CODE' && ref $opt->{dbh_fallback_connect} eq 'CODE') {
      $opt->{dbh_fallback_connect}->();
      my $dbh = $dbh->();
      return $self->_driver_for($dbh, $dsn)
         ->_get_when_connected({
            dbh => $dbh,
            dsn => $dsn,
            @args,
         })
   }

   die "wtf"
}

sub _driver_for {
   my ($self, $dbh, $dsn) = @_;

   if ($dbh and my $d = $dbh->{private_dbii_driver}) {
      if (my $found = $self->_drivers_by_name->{$d}) {
         return $found
      } else {
         warn "user requested non-existant driver $d"
      }
   }

   my $driver = $self->_root_driver;
   my $done;

   DETECT:
   do {
      $done = $driver->_determine($dbh, $dsn);
      if (!defined $done) {
         die "cannot figure out wtf this is"
      } elsif ($done ne 1) {
         $driver = $self->_drivers_by_name->{$done}
            or die "no such driver <$done>"
      }
   } while $done ne 1;

   return $driver
}

1;

__END__