Make $SIG{__WARN__} overrides more Carp::Always friendly

diff --git a/lib/DBIx/Class/Storage/DBI/ADO.pm b/lib/DBIx/Class/Storage/DBI/ADO.pm
index 705a598..db8517d 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI/ADO.pm
+++ b/lib/DBIx/Class/Storage/DBI/ADO.pm
@@ -8,6 +8,7 @@ use mro 'c3';
 
 use Sub::Name;
 use Try::Tiny;
+use DBIx::Class::_Util 'sigwarn_silencer';
 use namespace::clean;
 
 =head1 NAME
@@ -29,12 +30,9 @@ sub _rebless { shift->_determine_connector_driver('ADO') }
 sub _dbh_get_info {
   my $self = shift;
 
-  my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-
-  local $SIG{__WARN__} = sub {
-    $warn_handler->(@_)
-      unless $_[0] =~ m{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm};
-  };
+  local $SIG{__WARN__} = sigwarn_silencer(
+    qr{^Missing argument in sprintf at \S+/ADO/GetInfo\.pm}
+  );
 
   $self->next::method(@_);
 }
@@ -52,11 +50,9 @@ sub _init {
       my $disconnect = *DBD::ADO::db::disconnect{CODE};
 
       *DBD::ADO::db::disconnect = subname 'DBD::ADO::db::disconnect' => sub {
-        my $warn_handler = $SIG{__WARN__} || sub { warn @_ };
-        local $SIG{__WARN__} = sub {
-          $warn_handler->(@_)
-            unless $_[0] =~ /Not a Win32::OLE object|uninitialized value/;
-        };
+        local $SIG{__WARN__} = sigwarn_silencer(
+          qr/Not a Win32::OLE object|uninitialized value/
+        );
         $disconnect->(@_);
       };
     }

diff --git a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
index d2ad389..50a8f6b 100644 (file)
--- a/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
+++ b/lib/DBIx/Class/Storage/DBI/Sybase/ASE.pm
@@ -16,6 +16,7 @@ use Sub::Name();
 use Data::Dumper::Concise 'Dumper';
 use Try::Tiny;
 use Context::Preserve 'preserve_context';
+use DBIx::Class::_Util 'sigwarn_silencer';
 use namespace::clean;
 
 __PACKAGE__->sql_limit_dialect ('GenericSubQ');
@@ -180,9 +181,8 @@ sub disconnect {
 # "active statement" warning on disconnect, which we throw away here.
 # This is due to the bug described in insert_bulk.
 # Currently a noop because 'prepare' is used instead of 'prepare_cached'.
-  local $SIG{__WARN__} = sub {
-    warn $_[0] unless $_[0] =~ /active statement/i;
-  } if $self->_is_bulk_storage;
+  local $SIG{__WARN__} = sigwarn_silencer(qr/active statement/i)
+    if $self->_is_bulk_storage;
 
 # so that next transaction gets a dbh
   $self->_began_bulk_work(0) if $self->_is_bulk_storage;

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index e6cf2a9..5b3a427 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -10,7 +10,17 @@ use Carp;
 use Scalar::Util qw(refaddr weaken);
 
 use base 'Exporter';
-our @EXPORT_OK = qw(modver_gt_or_eq fail_on_internal_wantarray);
+our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray);
+
+sub sigwarn_silencer {
+  my $pattern = shift;
+
+  croak "Expecting a regexp" if ref $pattern ne 'Regexp';
+
+  my $orig_sig_warn = $SIG{__WARN__} || sub { CORE::warn(@_) };
+
+  return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
+}
 
 sub modver_gt_or_eq {
   my ($mod, $ver) = @_;
@@ -21,12 +31,8 @@ sub modver_gt_or_eq {
   croak "Nonsensical minimum version supplied"
     if ! defined $ver or $ver =~ /[^0-9\.\_]/;
 
-  local $SIG{__WARN__} = do {
-    my $orig_sig_warn = $SIG{__WARN__} || sub { warn @_ };
-    sub {
-      $orig_sig_warn->(@_) unless $_[0] =~ /\Qisn't numeric in subroutine entry/
-    }
-  } if SPURIOUS_VERSION_CHECK_WARNINGS;
+  local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ )
+    if SPURIOUS_VERSION_CHECK_WARNINGS;
 
   local $@;
   eval { $mod->VERSION($ver) } ? 1 : 0;

diff --git a/t/02_standalone_test_classes.t b/t/02_standalone_test_classes.t
index 48c70ac..38278c0 100644 (file)
--- a/t/02_standalone_test_classes.t
+++ b/t/02_standalone_test_classes.t
@@ -4,6 +4,8 @@ use strict;
 use Test::More;
 use File::Find;
 
+use DBIx::Class::_Util 'sigwarn_silencer';
+
 use lib 't/lib';
 
 find({
@@ -16,11 +18,11 @@ find({
       die "fork failed: $!"
     }
     elsif (!$pid) {
-      if (my @offenders = grep { $_ =~ /(^|\/)DBI/ } keys %INC) {
+      if (my @offenders = grep { $_ ne 'DBIx/Class/_Util.pm' } grep { $_ =~ /(^|\/)DBI/ } keys %INC) {
         die "Wtf - DBI* modules present in %INC: @offenders";
       }
 
-      local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /\bdeprecated\b/i };
+      local $SIG{__WARN__} = sigwarn_silencer( qr/\bdeprecated\b/i );
       require( ( $_ =~ m| t/lib/ (.+) |x )[0] ); # untaint and strip lib-part (. is unavailable under -T)
       exit 0;
     }

diff --git a/t/103many_to_many_warning.t b/t/103many_to_many_warning.t
index 9e5c19a..2c42091 100644 (file)
--- a/t/103many_to_many_warning.t
+++ b/t/103many_to_many_warning.t
@@ -5,7 +5,6 @@ use Test::More;
 use lib qw(t/lib);
 use DBICTest;
 
-plan tests => 4;
 my $exp_warn = qr/The many-to-many relationship 'bars' is trying to create/;
 
 {
@@ -103,3 +102,5 @@ use warnings;
 EOF
 
 }
+
+done_testing;

diff --git a/t/752sqlite.t b/t/752sqlite.t
index d9a8e5d..b273d97 100644 (file)
--- a/t/752sqlite.t
+++ b/t/752sqlite.t
@@ -9,7 +9,7 @@ use Config;
 
 use lib qw(t/lib);
 use DBICTest;
-use DBIx::Class::_Util 'modver_gt_or_eq';
+use DBIx::Class::_Util qw(sigwarn_silencer modver_gt_or_eq);
 
 # savepoints test
 {
@@ -64,7 +64,7 @@ for my $prefix_comment (qw/Begin_only Commit_only Begin_and_Commit/) {
   # FIXME warning won't help us for the time being
   # perhaps when (if ever) DBD::SQLite gets fixed,
   # we can do something extra here
-  local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /Internal transaction state .+? does not seem to match/ }
+  local $SIG{__WARN__} = sigwarn_silencer( qr/Internal transaction state .+? does not seem to match/ )
     if ( $lit_txn_todo && !$ENV{TEST_VERBOSE} );
 
   my ($c_begin, $c_commit) = map { $prefix_comment =~ $_ ? 1 : 0 } (qr/Begin/, qr/Commit/);

diff --git a/t/86sqlt.t b/t/86sqlt.t
index caea89f..87b90a5 100644 (file)
--- a/t/86sqlt.t
+++ b/t/86sqlt.t
@@ -2,6 +2,7 @@ use strict;
 use warnings;
 
 use Test::More;
+use Test::Warn;
 use lib qw(t/lib);
 use DBICTest;
 
@@ -118,19 +119,15 @@ my $schema = DBICTest->init_schema (no_deploy => 1);
 
 my $translator = SQL::Translator->new(
   parser_args => {
-    'DBIx::Schema' => $schema,
+    dbic_schema => $schema,
   },
   producer_args => {},
 );
 
-{
-    my $warn = '';
-    local $SIG{__WARN__} = sub { $warn = shift };
-
+warnings_exist {
     my $relinfo = $schema->source('Artist')->relationship_info ('cds');
     local $relinfo->{attrs}{on_delete} = 'restrict';
 
-
     $translator->parser('SQL::Translator::Parser::DBIx::Class');
     $translator->producer('SQLite');
 
@@ -139,13 +136,9 @@ my $translator = SQL::Translator->new(
     ok($output, "SQLT produced someoutput")
       or diag($translator->error);
 
-
-    like (
-      $warn,
-      qr/SQLT attribute .+? was supplied for relationship .+? which does not appear to be a foreign constraint/,
-      'Warn about dubious on_delete/on_update attributes',
-    );
-}
+} [
+  (qr/SQLT attribute .+? was supplied for relationship .+? which does not appear to be a foreign constraint/) x 2
+], 'Warn about dubious on_delete/on_update attributes';
 
 # Note that the constraints listed here are the only ones that are tested -- if
 # more exist in the Schema than are listed here and all listed constraints are

diff --git a/t/90ensure_class_loaded.t b/t/90ensure_class_loaded.t
index f14911d..e933c00 100644 (file)
--- a/t/90ensure_class_loaded.t
+++ b/t/90ensure_class_loaded.t
@@ -4,6 +4,7 @@ use warnings;
 use Test::More;
 use lib qw(t/lib);
 use DBICTest;
+use DBIx::Class::_Util 'sigwarn_silencer';
 use Class::Inspector;
 
 BEGIN {
@@ -100,13 +101,9 @@ ok( Class::Inspector->loaded('DBICTest::FakeComponent'),
 
 {
   # Squash warnings about syntax errors in SytaxErrorComponent.pm
-  local $SIG{__WARN__} = sub {
-    my $warning = shift;
-    warn $warning unless (
-      $warning =~ /String found where operator expected/ or
-      $warning =~ /Missing operator before/
-    );
-  };
+  local $SIG{__WARN__} = sigwarn_silencer(
+    qr/String found where operator expected|Missing operator before/
+  );
 
   eval { $schema->ensure_class_loaded('DBICTest::SyntaxErrorComponent1') };
   like( $@, qr/syntax error/,

diff --git a/t/94versioning.t b/t/94versioning.t
index 299ac2f..93fcca7 100644 (file)
--- a/t/94versioning.t
+++ b/t/94versioning.t
@@ -11,6 +11,7 @@ use Time::HiRes qw/time sleep/;
 
 use lib qw(t/lib);
 use DBICTest;
+use DBIx::Class::_Util 'sigwarn_silencer';
 
 my ($dsn, $user, $pass);
 
@@ -167,7 +168,7 @@ my $schema_v3 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_versio
 
 # attempt v1 -> v3 upgrade
 {
-  local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
+  local $SIG{__WARN__} = sigwarn_silencer( qr/Attempting upgrade\.$/ );
   $schema_v3->upgrade();
   is($schema_v3->get_db_version(), '3.0', 'db version number upgraded');
 }
@@ -196,7 +197,7 @@ my $schema_v3 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_versio
 
 # Then attempt v1 -> v3 upgrade
 {
-  local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
+  local $SIG{__WARN__} = sigwarn_silencer( qr/Attempting upgrade\.$/ );
   $schema_v3->upgrade();
   is($schema_v3->get_db_version(), '3.0', 'db version number upgraded to 3.0');
 
@@ -250,7 +251,8 @@ my $schema_v3 = DBICVersion::Schema->connect($dsn, $user, $pass, { ignore_versio
     $schema_v2->deploy;
   }
 
-  local $SIG{__WARN__} = sub { warn $_[0] if $_[0] !~ /Attempting upgrade\.$/ };
+  local $SIG{__WARN__} = sigwarn_silencer( qr/Attempting upgrade\.$/ );
+
   $schema_v2->upgrade();
 
   is($schema_v2->get_db_version(), '3.0', 'Fast deploy/upgrade');

diff --git a/t/99dbic_sqlt_parser.t b/t/99dbic_sqlt_parser.t
index 33c33c2..b8b57cf 100644 (file)
--- a/t/99dbic_sqlt_parser.t
+++ b/t/99dbic_sqlt_parser.t
@@ -8,6 +8,7 @@ use Scalar::Util ();
 
 use lib qw(t/lib);
 use DBICTest;
+use DBIx::Class::_Util 'sigwarn_silencer';
 
 BEGIN {
   require DBIx::Class;
@@ -78,6 +79,8 @@ SKIP: {
 
   eval <<'EOE' or die $@;
   END {
+    # we are in END - everything remains global
+    #
     $^W = 1;  # important, otherwise DBI won't trip the next fail()
     $SIG{__WARN__} = sub {
       fail "Unexpected global destruction warning"
@@ -216,10 +219,9 @@ lives_ok (sub {
   lives_ok (sub {
     my $sqlt_schema = do {
 
-      local $SIG{__WARN__} = sub {
-        warn @_
-          unless $_[0] =~ /Ignoring relationship .+ related resultsource .+ is not registered with this schema/
-      };
+      local $SIG{__WARN__} = sigwarn_silencer(
+        qr/Ignoring relationship .+ related resultsource .+ is not registered with this schema/
+      );
 
       create_schema({ schema => $partial_schema });
     };

diff --git a/t/admin/02ddl.t b/t/admin/02ddl.t
index 8b1c57f..1d9ce88 100644 (file)
--- a/t/admin/02ddl.t
+++ b/t/admin/02ddl.t
@@ -9,6 +9,7 @@ use Path::Class;
 
 use lib qw(t/lib);
 use DBICTest;
+use DBIx::Class::_Util 'sigwarn_silencer';
 
 BEGIN {
     require DBIx::Class;
@@ -48,7 +49,7 @@ isa_ok ($admin, 'DBIx::Class::Admin', 'create the admin object');
 lives_ok { $admin->create('MySQL'); } 'Can create MySQL sql';
 lives_ok { $admin->create('SQLite'); } 'Can Create SQLite sql';
 lives_ok {
-  $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /no such table.+DROP TABLE/s };
+  local $SIG{__WARN__} = sigwarn_silencer( qr/no such table.+DROP TABLE/s );
   $admin->deploy()
 } 'Can Deploy schema';
 }
@@ -86,9 +87,9 @@ $admin = DBIx::Class::Admin->new(
 
 lives_ok { $admin->create($schema->storage->sqlt_type(), {}, "1.0" ); } 'Can create diff for ' . $schema->storage->sqlt_type;
 {
-  local $SIG{__WARN__} = sub { warn $_[0] unless $_[0] =~ /DB version .+? is lower than the schema version/ };
-  lives_ok {$admin->upgrade();} 'upgrade the schema';
-  dies_ok {$admin->deploy} 'cannot deploy installed schema, should upgrade instead';
+  local $SIG{__WARN__} = sigwarn_silencer( qr/DB version .+? is lower than the schema version/ );
+  lives_ok { $admin->upgrade() } 'upgrade the schema';
+  dies_ok { $admin->deploy } 'cannot deploy installed schema, should upgrade instead';
 }
 
 is($schema->get_db_version, $DBICVersion::Schema::VERSION, 'Schema and db versions match');

diff --git a/t/inflate/datetime_mysql.t b/t/inflate/datetime_mysql.t
index a810810..44699ab 100644 (file)
--- a/t/inflate/datetime_mysql.t
+++ b/t/inflate/datetime_mysql.t
@@ -8,13 +8,14 @@ use DBIx::Class::Optional::Dependencies ();
 use lib qw(t/lib);
 use DBICTest;
 use DBICTest::Schema;
+use DBIx::Class::_Util 'sigwarn_silencer';
 
 plan skip_all => 'Inflation tests need ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_mysql')
   unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_mysql');
 
 {
-  local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
   DBICTest::Schema->load_classes('EventTZ');
+  local $SIG{__WARN__} = sigwarn_silencer( qr/extra \=\> .+? has been deprecated/ );
   DBICTest::Schema->load_classes('EventTZDeprecated');
 }
 

diff --git a/t/inflate/datetime_pg.t b/t/inflate/datetime_pg.t
index 0751561..c02e9f8 100644 (file)
--- a/t/inflate/datetime_pg.t
+++ b/t/inflate/datetime_pg.t
@@ -10,10 +10,7 @@ use DBICTest;
 plan skip_all => 'Test needs ' . DBIx::Class::Optional::Dependencies->req_missing_for ('test_dt_pg')
   unless DBIx::Class::Optional::Dependencies->req_ok_for ('test_dt_pg');
 
-{
-  local $SIG{__WARN__} = sub { warn @_ if $_[0] !~ /extra \=\> .+? has been deprecated/ };
-  DBICTest::Schema->load_classes('EventTZPg');
-}
+DBICTest::Schema->load_classes('EventTZPg');
 
 my $schema = DBICTest->init_schema();
 

diff --git a/t/multi_create/insert_defaults.t b/t/multi_create/insert_defaults.t
index f69f36a..3425b8a 100644 (file)
--- a/t/multi_create/insert_defaults.t
+++ b/t/multi_create/insert_defaults.t
@@ -4,8 +4,7 @@ use warnings;
 use Test::More;
 use lib qw(t/lib);
 use DBICTest;
-
-plan tests => 8;
+use DBIx::Class::_Util 'sigwarn_silencer';
 
 my $schema = DBICTest->init_schema();
 
@@ -39,6 +38,8 @@ is_deeply ({ $o0->columns}, {$last_bookmark->columns}, 'Correctly identify a row
 my $o3 = $last_link->create_related ('bookmarks', {});
 is ($o3->id, $last_bookmark->id + 3, '3rd bookmark ID');
 
-local $SIG{__WARN__} = sub { warn @_ unless $_[0] =~ /Query returned more than one row/ };
+local $SIG{__WARN__} = sigwarn_silencer( qr/Query returned more than one row/ );
 my $oX = $bookmark_rs->find_or_create ({ link => $last_link });
 is_deeply ({ $oX->columns}, {$last_bookmark->columns}, 'Correctly identify a row given a relationship');
+
+done_testing;