X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=be899eeb102b39524cdde2882c5af08c99797401;hb=d098704fa2e7e92b3a6cdf0a251f3e725623f9a4;hp=3c14189fc5cc7ab255f038d8cfc85ec99bb5e18c;hpb=db83437ef48f4571e1d225572cc7235eb5e64fe3;p=dbsrgits%2FDBIx-Class-Historic.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 3c14189..be899ee 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -23,12 +23,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 +52,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,7 +80,6 @@ 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); # Already correctly prototyped: perlbrew exec perl -MStorable -e 'warn prototype \&Storable::dclone' @@ -79,8 +90,10 @@ 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 - scope_guard is_exception detected_reinvoked_destructor - quote_sub qsub perlstring serialize deep_clone + scope_guard detected_reinvoked_destructor + is_exception dbic_internal_try + quote_sub qsub perlstring serialize deep_clone dump_value + parent_dir mkdir_p UNRESOLVABLE_CONDITION ); @@ -125,6 +138,42 @@ sub serialize ($) { 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; @@ -144,9 +193,11 @@ sub scope_guard (&) { eval { $_[0]->[0]->(); 1; - } or do { - Carp::cluck "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@"; - }; + } + or + Carp::cluck( + "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@" + ); } } @@ -163,6 +214,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 @@ -229,13 +281,98 @@ sub is_exception ($) { } { + my $callstack_state; + + # Recreate the logic of try(), while reusing the catch()/finally() as-is + # + # FIXME: We need to move away from Try::Tiny entirely (way too heavy and + # yes, shows up ON TOP of profiles) but this is a batle for another maint + sub dbic_internal_try (&;@) { + + my $try_cref = shift; + my $catch_cref = undef; # apparently this is a thing... https://rt.perl.org/Public/Bug/Display.html?id=119311 + + for my $arg (@_) { + + if( ref($arg) eq 'Try::Tiny::Catch' ) { + + croak 'dbic_internal_try() may not be followed by multiple catch() blocks' + if $catch_cref; + + $catch_cref = $$arg; + } + elsif ( ref($arg) eq 'Try::Tiny::Finally' ) { + croak 'dbic_internal_try() does not support finally{}'; + } + else { + croak( + 'dbic_internal_try() encountered an unexpected argument ' + . "'@{[ defined $arg ? $arg : 'UNDEF' ]}' - perhaps " + . 'a missing semi-colon before or ' # trailing space important + ); + } + } + + my $wantarray = wantarray; + my $preexisting_exception = $@; + + my @ret; + my $all_good = eval { + $@ = $preexisting_exception; + + local $callstack_state->{in_internal_try} = 1 + unless $callstack_state->{in_internal_try}; + + # always unset - someone may have snuck it in + local $SIG{__DIE__} if $SIG{__DIE__}; + + if( $wantarray ) { + @ret = $try_cref->(); + } + elsif( defined $wantarray ) { + $ret[0] = $try_cref->(); + } + else { + $try_cref->(); + } + + 1; + }; + + my $exception = $@; + $@ = $preexisting_exception; + + if ( $all_good ) { + return $wantarray ? @ret : $ret[0] + } + elsif ( $catch_cref ) { + for ( $exception ) { + return $catch_cref->($exception); + } + } + + return; + } + + sub in_internal_try { !! $callstack_state->{in_internal_try} } +} + +{ 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 + # may very well be just a preventive measure guarding future modifications + undef; } # This is almost invariably invoked from within DESTROY @@ -301,8 +438,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; }; @@ -322,6 +459,54 @@ sub modver_gt_or_eq_and_lt ($$$) { ) ? 1 : 0; } + +# +# Why not just use some higher-level module or at least File::Spec here? +# Because: +# 1) This is a *very* rarely used function, and the deptree is large +# enough already as it is +# +# 2) (more importantly) Our tooling is utter shit in this area. There +# is no comprehensive support for UNC paths in PathTools and there +# are also various small bugs in representation across different +# path-manipulation CPAN offerings. +# +# Since this routine is strictly used for logical path processing (it +# *must* be able to work with not-yet-existing paths), use this seemingly +# simple but I *think* complete implementation to feed to other consumers +# +# If bugs are ever uncovered in this routine, *YOU ARE URGED TO RESIST* +# the impulse to bring in an external dependency. During runtime there +# is exactly one spot that could potentially maybe once in a blue moon +# use this function. Keep it lean. +# +sub parent_dir ($) { + ( $_[0] =~ m{ [\/\\] ( \.{0,2} ) ( [\/\\]* ) \z }x ) + ? ( + $_[0] + . + ( ( length($1) and ! length($2) ) ? '/' : '' ) + . + '../' + ) + : ( + require File::Spec + and + File::Spec->catpath ( + ( File::Spec->splitpath( "$_[0]" ) )[0,1], + '/', + ) + ) + ; +} + +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; @@ -368,8 +553,8 @@ sub modver_gt_or_eq_and_lt ($$$) { ), 'with_stacktrace'); } - my $mark = []; - weaken ( $list_ctx_ok_stack_marker = $mark ); + weaken( $list_ctx_ok_stack_marker = my $mark = [] ); + $mark; } }