connection via coderef rather than explicit dsn/name/pass

diff --git a/Changes b/Changes
index 57f845f..6549a9f 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,6 @@
 Revision history for DBIx::Class
 
+        - Storage::DBI connect_info supports coderef returning dbh as 1st arg
         - add_components() doesn't prepend base when comp. prefixed with +
         - $schema->deploy
         - HAVING support

diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm
index 2e6e6c0..4e3e62c 100644 (file)
--- a/lib/DBIx/Class/Schema.pm
+++ b/lib/DBIx/Class/Schema.pm
@@ -36,8 +36,8 @@ DBIx::Class::Schema - composable schemas
     $password,
     $attrs
   );
-
-  my $schema2 = My::Schema->connect( ... );
+  
+  my $schema2 = My::Schema->connect($coderef_returning_dbh);
 
   # fetch objects using My::Schema::Foo
   my $resultset = $schema1->resultset('Foo')->search( ... );

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index 0a3e9c4..015fa3e 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -339,17 +339,25 @@ sub _populate_dbh {
 sub _connect {
   my ($self, @info) = @_;
 
+  my ($old_connect_via, $dbh);
+
   if ($INC{'Apache/DBI.pm'} && $ENV{MOD_PERL}) {
-      my $old_connect_via = $DBI::connect_via;
+      $old_connect_via = $DBI::connect_via;
       $DBI::connect_via = 'connect';
-      my $dbh = DBI->connect(@info);
-      $DBI::connect_via = $old_connect_via;
-      return $dbh;
   }
 
-  my $dbh = DBI->connect(@info);
+  if(ref $info[0] eq 'CODE') {
+      $dbh = &{$info[0]};
+  }
+  else {
+      $dbh = DBI->connect(@info);
+  }
+
+  $DBI::connect_via = $old_connect_via if $old_connect_via;
+
   $self->throw_exception("DBI Connection failed: $DBI::errstr")
       unless $dbh;
+
   $dbh;
 }
 
@@ -530,12 +538,7 @@ sub last_insert_id {
 
 }
 
-sub sqlt_type {
-  my ($self) = @_;
-  my $dsn = $self->connect_info->[0];
-  $dsn =~ /^dbi:(.*?)\d*:/;
-  return $1;
-}
+sub sqlt_type { shift->dbh->{Driver}->{Name} }
 
 sub deployment_statements {
   my ($self, $schema, $type) = @_;