From: Peter Rabbitson Date: Thu, 14 Jul 2016 11:03:26 +0000 (+0200) Subject: Add more forceful (STDERR-direct) warning emitter X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c40b5744f85a8ffc2da494464655936387c04251;p=dbsrgits%2FDBIx-Class-Historic.git Add more forceful (STDERR-direct) warning emitter Switch some of the most critical announements to it --- diff --git a/lib/DBIx/Class/Schema.pm b/lib/DBIx/Class/Schema.pm index 9b5b56b..702d472 100644 --- a/lib/DBIx/Class/Schema.pm +++ b/lib/DBIx/Class/Schema.pm @@ -12,7 +12,7 @@ use Scalar::Util qw/weaken blessed/; use DBIx::Class::_Util qw( refcount quote_sub scope_guard is_exception dbic_internal_try - fail_on_internal_call + fail_on_internal_call emit_loud_diag ); use Devel::GlobalDestruction; use namespace::clean; @@ -1089,8 +1089,8 @@ sub throw_exception { my $guard = scope_guard { return if $guard_disarmed; - local $SIG{__WARN__} if $SIG{__WARN__}; - Carp::cluck(" + emit_loud_diag( emit_dups => 1, msg => " + !!! DBIx::Class INTERNAL PANIC !!! The exception_action() handler installed on '$self' @@ -1103,7 +1103,7 @@ anything for other software that might be affected by a similar problem. !!! FIX YOUR ERROR HANDLING !!! -This guard was activated beginning" +This guard was activated starting", ); }; diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index b4fa5fb..8bca635 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -151,13 +151,11 @@ BEGIN { # to be outfits with *COPY PASTED* pieces of lib/DBIx/Class/Storage/* # in their production codebases. There is no point in breaking these # if whatever they used actually continues to work - my $warned; my $sigh = sub { - - require Carp; - my $cluck = "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" . Carp::longmess(); - - warn $cluck unless $warned->{$cluck}++; + DBIx::Class::_Util::emit_loud_diag( + skip_frames => 1, + msg => "The @{[ (caller(1))[3] ]} constant is no more - adjust your code" + ); 0; }; @@ -187,7 +185,7 @@ our @EXPORT_OK = qw( sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_wantarray fail_on_internal_call refdesc refcount hrefaddr set_subname describe_class_methods - scope_guard detected_reinvoked_destructor + scope_guard detected_reinvoked_destructor emit_loud_diag true false is_exception dbic_internal_try visit_namespaces quote_sub qsub perlstring serialize deep_clone dump_value uniq @@ -385,6 +383,61 @@ sub dump_value ($) { $dump_str; } +my $seen_loud_screams; +sub emit_loud_diag { + my $args = { ref $_[0] eq 'HASH' ? %{$_[0]} : @_ }; + + unless ( defined $args->{msg} and length $args->{msg} ) { + emit_loud_diag( + msg => "No 'msg' value supplied to emit_loud_diag()" + ); + exit 70; + } + + my $msg = "\n$0: $args->{msg}"; + + # when we die - we usually want to keep doing it + $args->{emit_dups} = !!$args->{confess} + unless exists $args->{emit_dups}; + + local $Carp::CarpLevel = + ( $args->{skip_frames} || 0 ) + + + $Carp::CarpLevel + + + # hide our own frame + 1 + ; + + my $longmess = Carp::longmess(); + + # different object references will thwart deduplication without this + ( my $key = "${msg}\n${longmess}" ) =~ s/\b0x[0-9a-f]+\b/0x.../gi; + + return $seen_loud_screams->{$key} if + $seen_loud_screams->{$key}++ + and + ! $args->{emit_dups} + ; + + $msg .= $longmess + unless $msg =~ /\n\z/; + + print STDERR "$msg\n" + or + print STDOUT "\n!!!STDERR ISN'T WRITABLE!!!:$msg\n"; + + return $seen_loud_screams->{$key} + unless $args->{confess}; + + # increment *again*, because... Carp. + $Carp::CarpLevel++; + + # not $msg - Carp will reapply the longmess on its own + Carp::confess($args->{msg}); +} + + ### ### This is *NOT* boolean.pm - deliberately not using a singleton ### @@ -420,8 +473,9 @@ sub scope_guard (&) { 1; } or - Carp::cluck( - "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@" + DBIx::Class::_Util::emit_loud_diag( + emit_dups => 1, + msg => "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@\n " ); } } @@ -486,18 +540,16 @@ sub is_exception ($) { and length( my $class = ref $e ) ) { - carp_unique( sprintf( - "Objects of external exception class '%s' stringify to '' (the " + carp_unique( + "Objects of external exception class '$class' stringify to '' (the " . 'empty string), implementing the so called null-object-pattern. ' . 'Given Perl\'s "globally cooperative" exception handling using this ' . 'class of exceptions is extremely dangerous, as it may (and often ' . 'does) result in silent discarding of errors. DBIx::Class tries to ' . 'work around this as much as possible, but other parts of your ' . 'software stack may not be even aware of the problem. Please submit ' - . 'a bugreport against the distribution containing %s', - - ($class) x 2, - )); + . "a bugreport against the distribution containing '$class'", + ); $not_blank = 1; } @@ -610,10 +662,10 @@ sub is_exception ($) { for keys %$destruction_registry; if (! length ref $_[0]) { - printf STDERR '%s() expects a blessed reference %s', - (caller(0))[3], - Carp::longmess, - ; + emit_loud_diag( + emit_dups => 1, + msg => (caller(0))[3] . '() expects a blessed reference' + ); return undef; # don't know wtf to do } elsif (! defined $destruction_registry->{ my $addr = refaddr($_[0]) } ) { @@ -621,7 +673,7 @@ sub is_exception ($) { return 0; } else { - carp_unique ( sprintf ( + emit_loud_diag( msg => sprintf ( 'Preventing *MULTIPLE* DESTROY() invocations on %s - an *EXTREMELY ' . 'DANGEROUS* condition which is *ALMOST CERTAINLY GLOBAL* within your ' . 'application, affecting *ALL* classes without active protection against ' diff --git a/t/35exception_inaction.t b/t/35exception_inaction.t index 2a3023b..0f775f4 100644 --- a/t/35exception_inaction.t +++ b/t/35exception_inaction.t @@ -72,6 +72,7 @@ ESCAPE: $schema->storage->ensure_connected; $schema->storage->_dbh->disconnect; + # silences "exitting sub via last" local $SIG{__WARN__} = sub {}; $schema->exception_action(sub { diff --git a/t/36double_destroy.t b/t/36double_destroy.t new file mode 100644 index 0000000..f070d14 --- /dev/null +++ b/t/36double_destroy.t @@ -0,0 +1,61 @@ +BEGIN { do "./t/lib/ANFANG.pm" or die ( $@ || $! ) } + +use strict; +use warnings; + +use Test::More; +use File::Temp (); + +use DBICTest::Util 'tmpdir'; +use DBIx::Class::_Util 'scope_guard'; + +use DBICTest; + +open(my $stderr_copy, '>&', *STDERR) or die "Unable to dup STDERR: $!"; +my $tf = File::Temp->new( UNLINK => 1, DIR => tmpdir() ); + +my $output; + +# ensure Devel::StackTrace-refcapture-like effects are countered +{ + my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); + my $g = $s->txn_scope_guard; + + my @arg_capture; + { + local $SIG{__WARN__} = sub { + package DB; + my $frnum; + while (my @f = CORE::caller(++$frnum) ) { + push @arg_capture, @DB::args; + } + }; + + undef $g; + 1; + } + + my $guard = scope_guard { + close STDERR; + open(STDERR, '>&', $stderr_copy); + $output = do { local (@ARGV, $/) = $tf; <> }; + close $tf; + unlink $tf; + undef $tf; + close $stderr_copy; + }; + + close STDERR; + open(STDERR, '>&', $tf) or die "Unable to reopen STDERR: $!"; + + # this should emit on stderr + @arg_capture = (); +} + +like( + $output, + qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/, + 'Proper warning emitted on STDERR' +); + +done_testing; diff --git a/t/storage/txn_scope_guard.t b/t/storage/txn_scope_guard.t index e9e69a3..09efcd7 100644 --- a/t/storage/txn_scope_guard.t +++ b/t/storage/txn_scope_guard.t @@ -239,29 +239,4 @@ require DBICTest::AntiPattern::NullObject; is(scalar @w, 0, 'no warnings \o/'); } -# ensure Devel::StackTrace-refcapture-like effects are countered -{ - my $s = DBICTest::Schema->connect('dbi:SQLite::memory:'); - my $g = $s->txn_scope_guard; - - my @arg_capture; - { - local $SIG{__WARN__} = sub { - package DB; - my $frnum; - while (my @f = CORE::caller(++$frnum) ) { - push @arg_capture, @DB::args; - } - }; - - undef $g; - 1; - } - - warnings_exist - { @arg_capture = () } - qr/\QPreventing *MULTIPLE* DESTROY() invocations on DBIx::Class::Storage::TxnScopeGuard/ - ; -} - done_testing;