initial commit

lib/DBIx/Introspector.pm

@@ -0,0 +1,113 @@
+package DBIx::Introspector;
+
+use Moo;
+use DBIx::Introspector::Driver;
+
+has _drivers => (
+   is => 'ro',
+   builder => '_build_drivers',
+   lazy => 1,
+);
+
+sub _build_drivers {
+   return [ map DBIx::Introspector::Driver->new($_),
+      {
+         name => 'DBI',
+         determination_strategy => sub { $_[1]->{Driver}{Name} },
+      },
+      { name => 'ACCESS',      parents => ['DBI'] },
+      { name => 'DB2',         parents => ['DBI'] },
+      { name => 'Informix',    parents => ['DBI'] },
+      { name => 'InterBase',   parents => ['DBI'] },
+      { name => 'MSSQL',       parents => ['DBI'] }, # 90% sure this is virtual
+      { 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',    parents => ['Interbase'] },
+      {
+         name => 'ODBC',
+         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 => ['ODBC'] },
+      { name => 'ODBC_DB2_400_SQL',          parents => ['ODBC'] },
+      { name => 'ODBC_Firebird',             parents => ['ODBC'] },
+      { name => 'ODBC_Microsoft_SQL_Server', parents => ['ODBC'] },
+      { name => 'ODBC_SQL_Anywhere',         parents => ['ODBC'] },
+      {
+         name => 'ADO',
+         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 => ['ADO'] },
+      { name => 'ADO_Microsoft_SQL_Server', parents => ['ADO'] },
+   ]
+}
+
+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) = @_;
+
+   die "driver must be a DBIx::Driver" unless $driver->isa('DBIx::Driver');
+
+   $self->_clear_drivers_by_name;
+   push @{$self->_drivers}, $driver
+}
+
+sub decorate_driver {
+   my ($self, $name, $key, $value) = @_;
+
+   if (my $d = $self->_drivers_by_name->{$name}) {
+      $d->_add_option($key => $value)
+   } else {
+      die "no such driver <$name>"
+   }
+}
+
+sub get {
+   my ($self, $dbh, $key) = @_;
+
+   $self->_driver_for($dbh)
+      ->_get($dbh, $self->_drivers_by_name, $key)
+}
+
+sub _driver_for {
+   my ($self, $dbh) = @_;
+
+   my $driver = $self->_root_driver;
+   my $done;
+
+   DETECT:
+   do {
+      $done = $driver->_determine($dbh);
+      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;

lib/DBIx/Introspector/Driver.pm

@@ -0,0 +1,79 @@
+package
+   DBIx::Introspector::Driver;
+
+use Moo;
+
+has name => (
+   is => 'ro',
+   required => 1,
+);
+
+has _determination_strategy => (
+   is => 'ro',
+   default => sub { sub { 1 } },
+   init_arg => 'determination_strategy',
+);
+
+has _options => (
+   is => 'ro',
+   builder => sub { 
+      +{
+         _introspector_driver => sub { $_[0]->name },
+      }
+   },
+   init_arg => 'options',
+);
+
+has _parents => (
+   is => 'ro',
+   default => sub { +[] },
+   init_arg => 'parents',
+);
+
+sub _add_option { shift->_options->{shift @_} = shift }
+
+sub _determine {
+   my ($self, $dbh) = @_;
+
+   my $strategy = $self->_determination_strategy;
+
+   $self->$strategy($dbh)
+}
+
+sub _get {
+   my ($self, $dbh, $drivers_by_name, $key) = @_;
+
+   my $option = $self->_options->{$key};
+
+   if ($option && ref $option && ref $option eq 'CODE') {
+      return $option->(@_)
+   }
+   elsif ($option and my $driver = $drivers_by_name->{$option}) {
+      $driver->_get(@_)
+   }
+   elsif (@{$self->_parents}) {
+      my @p = @{$self->_parents};
+      for my $parent (@p) {
+         my $ret = $parent->_get(@_);
+         return $ret if $ret
+      }
+   }
+   else {
+      return undef
+   }
+}
+
+sub _get_info_from_dbh {
+  my ($self, $dbh, $info) = @_;
+
+  if ($info =~ /[^0-9]/) {
+    require DBI::Const::GetInfoType;
+    $info = $DBI::Const::GetInfoType::GetInfoType{$info};
+    die "Info type '$_[1]' not provided by DBI::Const::GetInfoType"
+      unless defined $info;
+  }
+
+  $dbh->get_info($info);
+}
+
+1;

t/basic.t

@@ -0,0 +1,38 @@
+#!/usr/bin/env perl
+
+use Test::Roo;
+use DBI;
+use DBIx::Introspector;
+
+has [qw(dsn user password rdbms_engine introspector_driver)]
+   => ( is => 'ro' );
+
+test basic => sub {
+   my $self = shift;
+
+   my $d = DBIx::Introspector->new();
+
+   my $dbh = DBI->connect($self->dsn);
+   is(
+      $d->get($dbh, '_introspector_driver'),
+      $self->introspector_driver,
+      'introspector driver'
+   );
+
+   # is($d->_storage->rdbms_engine, $self->rdbms_engine, 'engine');
+};
+
+run_me('ODBC SQL Server', {
+   rdbms_engine => 'SQL Server',
+   dsn => $ENV{ODBC_MSSQL_DSN},
+   introspector_driver => 'ODBC_Microsoft_SQL_Server',
+}) if $ENV{ODBC_MSSQL_DSN};
+
+run_me(SQLite => {
+   rdbms_engine => 'SQLite',
+   introspector_driver => 'SQLite',
+   dsn => 'dbi:SQLite::memory:',
+});
+
+done_testing;
+