X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=4afa4c22599e7f900fa33dc00cf6ad6e0339216c;hb=d52fc26dd05b56a41494a5ec86cddecfe3587b96;hp=4829539a40efa42f2583635133081016c1009901;hpb=69016f65df5f30e446734b8cc94c216915c9105b;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 4829539..4afa4c2 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -4,7 +4,7 @@ package # hide from PAUSE use warnings; use strict; -use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0); +use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( "$]" < 5.010 ? 1 : 0); BEGIN { package # hide from pause @@ -17,32 +17,40 @@ BEGIN { # but of course BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, - BROKEN_GOTO => ($] < '5.008003') ? 1 : 0, + BROKEN_GOTO => ( "$]" < 5.008003 ) ? 1 : 0, HAS_ITHREADS => $Config{useithreads} ? 1 : 0, + 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) ), - - SHUFFLE_UNORDERED_RESULTSETS => $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} ? 1 : 0, - - ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0, - - ASSERT_NO_INTERNAL_INDIRECT_CALLS => $ENV{DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS} ? 1 : 0, - - STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE => $ENV{DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE} ? 1 : 0, - - STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE => $ENV{DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE} ? 1 : 0, + 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 + # all envvars without further adjusting its scripts + # DO NOT CHANGE to the more logical { $_ => !!( $ENV{"DBIC_$_"} ) } + # + { substr($_, 5) => !!( $ENV{$_} ) } + qw( + DBIC_SHUFFLE_UNORDERED_RESULTSETS + DBIC_ASSERT_NO_INTERNAL_WANTARRAY + DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS + DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE + DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE + ) + ), IV_SIZE => $Config{ivsize}, OS_NAME => $^O, }; - if ($] < 5.009_005) { + if ( "$]" < 5.009_005) { require MRO::Compat; constant->import( OLD_MRO => 1 ); } @@ -70,7 +78,9 @@ 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 is_exception detected_reinvoked_destructor + refdesc refcount hrefaddr + scope_guard detected_reinvoked_destructor + is_exception dbic_internal_try quote_sub qsub perlstring serialize deep_clone UNRESOLVABLE_CONDITION ); @@ -116,9 +126,38 @@ sub serialize ($) { nfreeze($_[0]); } +sub scope_guard (&) { + croak 'Calling scope_guard() in void context makes no sense' + if ! defined wantarray; + + # no direct blessing of coderefs - DESTROY is buggy on those + bless [ $_[0] ], 'DBIx::Class::_Util::ScopeGuard'; +} +{ + package # + DBIx::Class::_Util::ScopeGuard; + + sub DESTROY { + &DBIx::Class::_Util::detected_reinvoked_destructor; + + local $@ if DBIx::Class::_ENV_::UNSTABLE_DOLLARAT; + + eval { + $_[0]->[0]->(); + 1; + } + or + Carp::cluck( + "Execution of scope guard $_[0] resulted in the non-trappable exception:\n\n$@" + ); + } +} + + sub is_exception ($) { my $e = $_[0]; + # FIXME # this is not strictly correct - an eval setting $@ to undef # is *not* the same as an eval setting $@ to '' # but for the sake of simplicity assume the following for @@ -129,7 +168,10 @@ sub is_exception ($) { { local $@; eval { - $not_blank = ($e ne '') ? 1 : 0; + # The ne() here is deliberate - a plain length($e), or worse "$e" ne + # will entirely obviate the need for the encolsing eval{}, as the + # condition we guard against is a missing fallback overload + $not_blank = ( $e ne '' ); 1; } or $suberror = $@; } @@ -156,7 +198,7 @@ sub is_exception ($) { )); # workaround, keeps spice flowing - $not_blank = ("$e" ne '') ? 1 : 0; + $not_blank = !!( length $e ); } else { # not blessed yet failed the 'ne'... this makes 0 sense... @@ -178,7 +220,7 @@ sub is_exception ($) { . '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.', + . 'a bugreport against the distribution containing %s', ($class) x 2, )); @@ -190,6 +232,85 @@ 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 { @@ -197,6 +318,11 @@ sub is_exception ($) { { defined $_ ? ( refaddr($_) => $_ ) : () } 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 @@ -237,30 +363,44 @@ sub is_exception ($) { } } +my $module_name_rx = qr/ \A [A-Z_a-z] [0-9A-Z_a-z]* (?: :: [0-9A-Z_a-z]+ )* \z /x; +my $ver_rx = qr/ \A [0-9]+ (?: \. [0-9]+ )* (?: \_ [0-9]+ )* \z /x; + sub modver_gt_or_eq ($$) { my ($mod, $ver) = @_; croak "Nonsensical module name supplied" - if ! defined $mod or ! length $mod; + if ! defined $mod or $mod !~ $module_name_rx; croak "Nonsensical minimum version supplied" - if ! defined $ver or $ver =~ /[^0-9\.\_]/; + if ! defined $ver or $ver !~ $ver_rx; + + no strict 'refs'; + my $ver_cache = ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= ( $mod->VERSION + ? {} + : croak "$mod does not seem to provide a version (perhaps it never loaded)" + ); + + ! defined $ver_cache->{$ver} + and + $ver_cache->{$ver} = do { - local $SIG{__WARN__} = sigwarn_silencer( qr/\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; - croak "$mod does not seem to provide a version (perhaps it never loaded)" - unless $mod->VERSION; + local $@; + local $SIG{__DIE__}; + eval { $mod->VERSION($ver) } ? 1 : 0; + }; - local $@; - eval { $mod->VERSION($ver) } ? 1 : 0; + $ver_cache->{$ver}; } sub modver_gt_or_eq_and_lt ($$$) { my ($mod, $v_ge, $v_lt) = @_; croak "Nonsensical maximum version supplied" - if ! defined $v_lt or $v_lt =~ /[^0-9\.\_]/; + if ! defined $v_lt or $v_lt !~ $ver_rx; return ( modver_gt_or_eq($mod, $v_ge)