Merge 'trunk' into 'sybase'

r7425@Thesaurus (orig r7422):  ribasushi | 2009-08-29 08:55:12 +0200
Make podcoverage happy
r7426@Thesaurus (orig r7423):  ribasushi | 2009-08-29 09:06:07 +0200
Reduce the number of heavy dbh_do calls
r7439@Thesaurus (orig r7436):  ribasushi | 2009-08-30 08:54:10 +0200
 r7435@Thesaurus (orig r7432):  caelum | 2009-08-30 02:53:21 +0200
 new branch
 r7436@Thesaurus (orig r7433):  caelum | 2009-08-30 03:14:36 +0200
 add dbh_maker option to connect_info hash
 r7437@Thesaurus (orig r7434):  ribasushi | 2009-08-30 08:51:14 +0200
 Minor cleanup and test enhancement
 r7438@Thesaurus (orig r7435):  ribasushi | 2009-08-30 08:53:59 +0200
 Changes

diff --git a/Changes b/Changes
index cc2a415..07cc546 100644 (file)
--- a/Changes
+++ b/Changes
@@ -11,6 +11,8 @@ Revision history for DBIx::Class
             when needed
           - Support for interpolated variables with proper quoting when
             connecting to an older Sybase and/or via FreeTDS
+        - The hashref to connection_info now accepts a 'dbh_maker'
+          coderef, allowing better intergration with Catalyst
         - Fixed a complex prefetch + regular join regression introduced
           in 0.08108
         - SQLT related fixes:

diff --git a/Makefile.PL b/Makefile.PL
index d1dcf06..b6d7cf6 100644 (file)
--- a/Makefile.PL
+++ b/Makefile.PL
@@ -14,7 +14,7 @@ test_requires 'Test::Builder'       => 0.33;
 test_requires 'Test::Deep'          => 0;
 test_requires 'Test::Exception'     => 0;
 test_requires 'Test::More'          => 0.92;
-test_requires 'Test::Warn'          => 0.11;
+test_requires 'Test::Warn'          => 0.21;
 
 test_requires 'File::Temp'          => 0.22;
 

diff --git a/lib/DBIx/Class/Storage/DBI.pm b/lib/DBIx/Class/Storage/DBI.pm
index eb923d1..b2a92ef 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI.pm
+++ b/lib/DBIx/Class/Storage/DBI.pm
@@ -112,6 +112,12 @@ mixed together:
     %extra_attributes,
   }];
 
+  $connect_info_args = [{
+    dbh_maker => sub { DBI->connect (...) },
+    %dbi_attributes,
+    %extra_attributes,
+  }];
+
 This is particularly useful for L<Catalyst> based applications, allowing the
 following config (L<Config::General> style):
 
@@ -125,6 +131,10 @@ following config (L<Config::General> style):
     </connect_info>
   </Model::DB>
 
+The C<dsn>/C<user>/C<password> combination can be substituted by the
+C<dbh_maker> key whose value is a coderef that returns a connected
+L<DBI database handle|DBI/connect>
+
 =back
 
 Please note that the L<DBI> docs recommend that you always explicitly
@@ -337,6 +347,12 @@ L<DBIx::Class::Schema/connect>
   # Connect via subref
   ->connect_info([ sub { DBI->connect(...) } ]);
 
+  # Connect via subref in hashref
+  ->connect_info([{
+    dbh_maker => sub { DBI->connect(...) },
+    on_connect_do => 'alter session ...',
+  }]);
+
   # A bit more complicated
   ->connect_info(
     [
@@ -407,8 +423,21 @@ sub connect_info {
   elsif (ref $args[0] eq 'HASH') { # single hashref (i.e. Catalyst config)
     %attrs = %{$args[0]};
     @args = ();
-    for (qw/password user dsn/) {
-      unshift @args, delete $attrs{$_};
+    if (my $code = delete $attrs{dbh_maker}) {
+      @args = $code;
+
+      my @ignored = grep { delete $attrs{$_} } (qw/dsn user password/);
+      if (@ignored) {
+        carp sprintf (
+            'Attribute(s) %s in connect_info were ignored, as they can not be applied '
+          . "to the result of 'dbh_maker'",
+
+          join (', ', map { "'$_'" } (@ignored) ),
+        );
+      }
+    }
+    else {
+      @args = delete @attrs{qw/dsn user password/};
     }
   }
   else {                # otherwise assume dsn/user/password + \%attrs + \%extra_attrs
@@ -1238,7 +1267,7 @@ sub _dbh_execute {
 
 sub _execute {
     my $self = shift;
-    $self->dbh_do('_dbh_execute', @_)
+    $self->dbh_do('_dbh_execute', @_);  # retry over disconnects
 }
 
 sub insert {
@@ -2018,7 +2047,7 @@ sub _dbh_sth {
 
 sub sth {
   my ($self, $sql) = @_;
-  $self->dbh_do('_dbh_sth', $sql);
+  $self->dbh_do('_dbh_sth', $sql);  # retry over disconnects
 }
 
 sub _dbh_columns_info_for {
@@ -2080,7 +2109,7 @@ sub _dbh_columns_info_for {
 
 sub columns_info_for {
   my ($self, $table) = @_;
-  $self->dbh_do('_dbh_columns_info_for', $table);
+  $self->_dbh_columns_info_for ($self->_get_dbh, $table);
 }
 
 =head2 last_insert_id
@@ -2106,7 +2135,7 @@ EOE
 
 sub last_insert_id {
   my $self = shift;
-  $self->dbh_do('_dbh_last_insert_id', @_);
+  $self->_dbh_last_insert_id ($self->_dbh, @_);
 }
 
 =head2 _native_data_type

diff --git a/lib/DBIx/Class/Storage/DBI/Pg.pm b/lib/DBIx/Class/Storage/DBI/Pg.pm
index 9314396..2a7b529 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI/Pg.pm
+++ b/lib/DBIx/Class/Storage/DBI/Pg.pm
@@ -19,20 +19,24 @@ sub with_deferred_fk_checks {
   $sub->();
 }
 
-sub _dbh_last_insert_id {
-  my ($self, $dbh, $seq) = @_;
-  $dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
-}
-
 sub last_insert_id {
   my ($self,$source,$col) = @_;
   my $seq = ($source->column_info($col)->{sequence} ||= $self->get_autoinc_seq($source,$col));
   $self->throw_exception("could not fetch primary key for " . $source->name . ", could not "
     . "get autoinc sequence for $col (check that table and column specifications are correct "
     . "and in the correct case)") unless defined $seq;
-  $self->dbh_do('_dbh_last_insert_id', $seq);
+
+  $self->_dbh_last_insert_id ($self->_dbh, $seq);
 }
 
+# there seems to be absolutely no reason to have this as a separate method,
+# but leaving intact in case someone is already overriding it
+sub _dbh_last_insert_id {
+  my ($self, $dbh, $seq) = @_;
+  $dbh->last_insert_id(undef, undef, undef, undef, {sequence => $seq});
+}
+
+
 sub _get_pg_search_path {
     my ($self,$dbh) = @_;
     # cache the search path as ['schema','schema',...] in the storage

diff --git a/t/03podcoverage.t b/t/03podcoverage.t
index a2eaa47..6fd81ac 100644 (file)
--- a/t/03podcoverage.t
+++ b/t/03podcoverage.t
@@ -125,6 +125,7 @@ my $exceptions = {
     'DBIx::Class::Storage::DBI::Pg'                     => { skip => 1 },
     'DBIx::Class::Storage::DBI::SQLite'                 => { skip => 1 },
     'DBIx::Class::Storage::DBI::mysql'                  => { skip => 1 },
+    'DBIx::Class::Storage::DBI::AutoCast'               => { skip => 1 },
     'DBIx::Class::SQLAHacks'                            => { skip => 1 },
     'DBIx::Class::SQLAHacks::MySQL'                     => { skip => 1 },
     'DBIx::Class::SQLAHacks::MSSQL'                     => { skip => 1 },

diff --git a/t/storage/base.t b/t/storage/base.t
index c8a0bba..c0bde46 100644 (file)
--- a/t/storage/base.t
+++ b/t/storage/base.t
@@ -1,7 +1,8 @@
 use strict;
-use warnings;  
+use warnings;
 
 use Test::More;
+use Test::Warn;
 use lib qw(t/lib);
 use DBICTest;
 use Data::Dumper;
@@ -33,8 +34,6 @@ use Data::Dumper;
     }
 }
 
-plan tests => 17;
-
 my $schema = DBICTest->init_schema( sqlite_use_file => 1 );
 
 is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite',
@@ -145,6 +144,19 @@ my $invocations = {
           },
       ],
   },
+  'connect_info ([ \%attr_with_coderef ])' => {
+      args => [ {
+        dbh_maker => $coderef,
+        dsn => 'blah',
+        user => 'bleh',
+        on_connect_do => [qw/a b c/],
+        on_disconnect_do => [qw/d e f/],
+      } ],
+      dbi_connect_info => [
+        $coderef
+      ],
+      warn => qr/Attribute\(s\) 'dsn', 'user' in connect_info were ignored/,
+  },
 };
 
 for my $type (keys %$invocations) {
@@ -154,11 +166,14 @@ for my $type (keys %$invocations) {
   local $Data::Dumper::Sortkeys = 1;
   my $arg_dump = Dumper ($invocations->{$type}{args});
 
-  $storage->connect_info ($invocations->{$type}{args});
+  warnings_exist (
+    sub { $storage->connect_info ($invocations->{$type}{args}) },
+     $invocations->{$type}{warn} || (),
+    'Warned about ignored attributes',
+  );
 
   is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments");
 
-
   is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info");
   ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref");
 
@@ -169,4 +184,6 @@ for my $type (keys %$invocations) {
   );
 }
 
+done_testing;
+
 1;