diff --git a/lib/DBIx/Introspector.pm b/lib/DBIx/Introspector.pm new file mode 100644 index 0000000..5937edb --- /dev/null +++ b/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; diff --git a/lib/DBIx/Introspector/Driver.pm b/lib/DBIx/Introspector/Driver.pm new file mode 100644 index 0000000..b6fc3fb --- /dev/null +++ b/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; diff --git a/t/basic.t b/t/basic.t new file mode 100644 index 0000000..c2d3175 --- /dev/null +++ b/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; +