X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=a8785c08c567ea216429c15897ac2bb37dd0948d;hb=b090048f6d8bd2cba0bae8ea7ec26459dd20dca8;hp=a8c78d4b383aada36b19ebac2e2686ea326e8c1b;hpb=953f8eb062bd84ffcb5b59d9a0d27d1db55f3927;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index a8c78d4..a8785c0 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -91,7 +91,15 @@ BEGIN { {( # stringification should be sufficient, ignore names/refaddr entirely $_, - attributes::get( $_ ), + do { + my @attrs; + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + # attributes::get may throw on blessed-false crefs :/ + eval { @attrs = attributes::get( $_ ); 1 } + or warn "Unable to determine attributes of coderef $_ due to the following error: $@"; + @attrs; + }, )} map {( @@ -143,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; }; @@ -178,8 +184,8 @@ use base 'Exporter'; 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 + refdesc refcount hrefaddr set_subname get_subname describe_class_methods + 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 @@ -317,7 +323,14 @@ sub visit_namespaces { $visited_count; } -# FIXME In another life switch this to a polyfill like the one in namespace::clean +# FIXME In another life switch these to a polyfill like the ones in namespace::clean +sub get_subname ($) { + my $gv = B::svref_2object( $_[0] )->GV; + wantarray + ? ( $gv->STASH->NAME, $gv->NAME ) + : ( join '::', $gv->STASH->NAME, $gv->NAME ) + ; +} sub set_subname ($$) { # fully qualify name @@ -377,6 +390,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 ### @@ -412,8 +480,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 " ); } } @@ -478,18 +547,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; } @@ -602,10 +669,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]) } ) { @@ -613,7 +680,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 ' @@ -810,9 +877,15 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? { via_class => $class, name => $_, - attributes => { - map { $_ => 1 } attributes::get( \&{"${class}::${_}"} ) - }, + attributes => { map { $_ => 1 } do { + my @attrs; + local $@; + local $SIG{__DIE__} if $SIG{__DIE__}; + # attributes::get may throw on blessed-false crefs :/ + eval { @attrs = attributes::get( \&{"${class}::${_}"} ); 1 } + or warn "Unable to determine attributes of the \\&${class}::$_ method due to following error: $@"; + @attrs; + } }, } : () } keys %{"${class}::"} )