From: Peter Rabbitson Date: Tue, 8 Oct 2013 22:28:46 +0000 (+0200) Subject: Make $SIG{__WARN__} overrides more Carp::Always friendly X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=052a832c5f6fe0f82a4db48e176525f700c44159;p=dbsrgits%2FDBIx-Class-Historic.git 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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;