X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=a20705d96992ca844238f0308221464855df3878;hb=b46b85376ad7ff53fa4ec4350a19b4514c4e0d3b;hp=846920df4bc056a43e6207cd744954b150aae82a;hpb=e3be2b6ff05d6794ccd8807af8cb494403690639;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 846920d..a20705d 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1,6 +1,8 @@ package # hide from PAUSE DBIx::Class::_Util; +use DBIx::Class::StartupCheck; # load es early as we can, usually a noop + use warnings; use strict; @@ -23,12 +25,6 @@ BEGIN { UNSTABLE_DOLLARAT => ( "$]" < 5.013002 ) ? 1 : 0, - DBICTEST => $INC{"DBICTest/Util.pm"} ? 1 : 0, - - # During 5.13 dev cycle HELEMs started to leak on copy - # add an escape for these perls ON SMOKERS - a user will still get death - PEEPEENESS => ( eval { DBICTest::RunMode->is_smoker } && ( "$]" >= 5.013005 and "$]" <= 5.013006) ), - ( map # # the "DBIC_" prefix below is crucial - this is what makes CI pick up @@ -58,6 +54,24 @@ BEGIN { require mro; constant->import( OLD_MRO => 0 ); } + + # Both of these are no longer used for anything. However bring + # them back after they were purged in 08a8d8f1, as there appear + # 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}++; + + 0; + }; + sub DBICTEST () { &$sigh } + sub PEEPEENESS () { &$sigh } } # FIXME - this is not supposed to be here @@ -68,8 +82,8 @@ use B (); use Carp 'croak'; use Storable 'nfreeze'; use Scalar::Util qw(weaken blessed reftype refaddr); -use List::Util qw(first); use Sub::Quote qw(qsub quote_sub); +use Sub::Name (); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' BEGIN { *deep_clone = \&Storable::dclone } @@ -78,11 +92,11 @@ 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 + refdesc refcount hrefaddr set_subname scope_guard detected_reinvoked_destructor is_exception dbic_internal_try - quote_sub qsub perlstring serialize deep_clone - parent_dir + quote_sub qsub perlstring serialize deep_clone dump_value + parent_dir mkdir_p UNRESOLVABLE_CONDITION ); @@ -122,11 +136,57 @@ sub refcount ($) { B::svref_2object($_[0])->REFCNT; } +# FIXME In another life switch this to a polyfill like the one in namespace::clean +sub set_subname ($$) { + + # fully qualify name + splice @_, 0, 1, caller(0) . "::$_[0]" + if $_[0] !~ /::|'/; + + &Sub::Name::subname; +} + sub serialize ($) { local $Storable::canonical = 1; nfreeze($_[0]); } +my $dd_obj; +sub dump_value ($) { + local $Data::Dumper::Indent = 1 + unless defined $Data::Dumper::Indent; + + my $dump_str = ( + $dd_obj + ||= + do { + require Data::Dumper; + my $d = Data::Dumper->new([]) + ->Purity(0) + ->Pad('') + ->Useqq(1) + ->Terse(1) + ->Freezer('') + ->Quotekeys(0) + ->Bless('bless') + ->Pair(' => ') + ->Sortkeys(1) + ->Deparse(1) + ; + + $d->Sparseseen(1) if modver_gt_or_eq ( + 'Data::Dumper', '2.136' + ); + + $d; + } + )->Values([$_[0]])->Dump; + + $dd_obj->Reset->Values([]); + + $dump_str; +} + sub scope_guard (&) { croak 'Calling scope_guard() in void context makes no sense' if ! defined wantarray; @@ -167,6 +227,7 @@ sub is_exception ($) { my ($not_blank, $suberror); { + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { # The ne() here is deliberate - a plain length($e), or worse "$e" ne @@ -276,9 +337,7 @@ sub is_exception ($) { unless $callstack_state->{in_internal_try}; # always unset - someone may have snuck it in - local $SIG{__DIE__} - if $SIG{__DIE__}; - + local $SIG{__DIE__} if $SIG{__DIE__}; if( $wantarray ) { @ret = $try_cref->(); @@ -315,10 +374,13 @@ sub is_exception ($) { my $destruction_registry = {}; sub CLONE { - $destruction_registry = { map - { defined $_ ? ( refaddr($_) => $_ ) : () } - values %$destruction_registry - }; + %$destruction_registry = map { + (defined $_) + ? ( refaddr($_) => $_ ) + : () + } values %$destruction_registry; + + weaken($_) for values %$destruction_registry; # Dummy NEXTSTATE ensuring the all temporaries on the stack are garbage # collected before leaving this scope. Depending on the code above, this @@ -389,8 +451,8 @@ sub modver_gt_or_eq ($$) { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ ) if SPURIOUS_VERSION_CHECK_WARNINGS; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; - local $SIG{__DIE__}; eval { $mod->VERSION($ver) } ? 1 : 0; }; @@ -451,6 +513,12 @@ sub parent_dir ($) { ; } +sub mkdir_p ($) { + require File::Path; + # do not ask for a recent version, use 1.x API calls + File::Path::mkpath([ "$_[0]" ]); # File::Path does not like objects +} + { my $list_ctx_ok_stack_marker; @@ -498,8 +566,8 @@ sub parent_dir ($) { ), 'with_stacktrace'); } - my $mark = []; - weaken ( $list_ctx_ok_stack_marker = $mark ); + weaken( $list_ctx_ok_stack_marker = my $mark = [] ); + $mark; } } @@ -511,7 +579,7 @@ sub fail_on_internal_call { $fr = [ CORE::caller(1) ]; $argdesc = ref $DB::args[0] ? DBIx::Class::_Util::refdesc($DB::args[0]) - : undef + : ( $DB::args[0] . '' ) ; }; @@ -523,7 +591,7 @@ sub fail_on_internal_call { $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there ) { DBIx::Class::Exception->throw( sprintf ( - "Illegal internal call of indirect proxy-method %s() with argument %s: examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", + "Illegal internal call of indirect proxy-method %s() with argument '%s': examine the last lines of the proxy method deparse below to determine what to call directly instead at %s on line %d\n\n%s\n\n Stacktrace starts", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do { require B::Deparse; no strict 'refs';