X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=7e0520b233de516fe242ed094dc190a3142d0a02;hb=dc7d89911b7bb98c30208cf73af522a99998dcd6;hp=b640e7695b81a02d86379bd4ecd15dbd0fe5657f;hpb=534aff612dee17fe18831e445d464d942c27c172;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index b640e76..7e0520b 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -1,7 +1,8 @@ package # hide from PAUSE DBIx::Class::_Util; -use DBIx::Class::StartupCheck; # load es early as we can, usually a noop +# load es early as we can, usually a noop +use DBIx::Class::StartupCheck; use warnings; use strict; @@ -47,9 +48,10 @@ BEGIN { { substr($_, 5) => !!( $ENV{$_} ) } qw( DBIC_SHUFFLE_UNORDERED_RESULTSETS - DBIC_ASSERT_NO_INTERNAL_WANTARRAY DBIC_ASSERT_NO_INTERNAL_INDIRECT_CALLS DBIC_ASSERT_NO_ERRONEOUS_METAINSTANCE_USE + DBIC_ASSERT_NO_FAILING_SANITY_CHECKS + DBIC_ASSERT_NO_INCONSISTENT_RELATIONSHIP_RESOLUTION DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE DBIC_STRESSTEST_COLUMN_INFO_UNAWARE_STORAGE ) @@ -172,6 +174,9 @@ use constant SPURIOUS_VERSION_CHECK_WARNINGS => ( DBIx::Class::_ENV_::PERL_VERSI # Carp::Skip to the rescue soon use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; +# Ensure it is always there, in case we need to do a $schema-less throw() +use DBIx::Class::Exception (); + use B (); use Carp 'croak'; use Storable 'nfreeze'; @@ -192,19 +197,23 @@ BEGIN { *deep_clone = \&Storable::dclone } 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 + sigwarn_silencer modver_gt_or_eq modver_gt_or_eq_and_lt fail_on_internal_call 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 + is_exception dbic_internal_try dbic_internal_catch visit_namespaces + quote_sub qsub perlstring serialize deep_clone dump_value uniq bag_eq parent_dir mkdir_p - UNRESOLVABLE_CONDITION + UNRESOLVABLE_CONDITION DUMMY_ALIASPAIR ); use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; +use constant DUMMY_ALIASPAIR => ( + foreign_alias => "!!!\xFF()!!!_DUMMY_FOREIGN_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFF!!!", + self_alias => "!!!\xFE()!!!_DUMMY_SELF_ALIAS_SHOULD_NEVER_BE_SEEN_IN_USE_!!!()\xFE!!!", +); + # Override forcing no_defer, and adding naming consistency checks our %refs_closed_over_by_quote_sub_installed_crefs; sub quote_sub { @@ -351,7 +360,19 @@ sub set_subname ($$) { } sub serialize ($) { + # stable hash order local $Storable::canonical = 1; + + # explicitly false - there is nothing sensible that can come out of + # an attempt at CODE serialization + local $Storable::Deparse; + + # take no chances + local $Storable::forgive_me; + + # FIXME + # A number of codepaths *expect* this to be Storable.pm-based so that + # the STORABLE_freeze hooks in the metadata subtree get executed properly nfreeze($_[0]); } @@ -364,6 +385,34 @@ sub uniq { ) } @_; } +sub bag_eq ($$) { + croak "bag_eq() requiress two arrayrefs as arguments" if ( + ref($_[0]) ne 'ARRAY' + or + ref($_[1]) ne 'ARRAY' + ); + + return '' unless @{$_[0]} == @{$_[1]}; + + my( %seen, $numeric_preserving_copy ); + + ( defined $_ + ? $seen{'value' . ( $numeric_preserving_copy = $_ )}++ + : $seen{'undef'}++ + ) for @{$_[0]}; + + ( defined $_ + ? $seen{'value' . ( $numeric_preserving_copy = $_ )}-- + : $seen{'undef'}-- + ) for @{$_[1]}; + + return ( + (grep { $_ } values %seen) + ? '' + : 1 + ); +} + my $dd_obj; sub dump_value ($) { local $Data::Dumper::Indent = 1 @@ -387,9 +436,20 @@ sub dump_value ($) { ->Deparse(1) ; - $d->Sparseseen(1) if modver_gt_or_eq ( - 'Data::Dumper', '2.136' - ); + # FIXME - this is kinda ridiculous - there ought to be a + # Data::Dumper->new_with_defaults or somesuch... + # + if( modver_gt_or_eq ( 'Data::Dumper', '2.136' ) ) { + $d->Sparseseen(1); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.153' ) ) { + $d->Maxrecurse(1000); + + if( modver_gt_or_eq ( 'Data::Dumper', '2.160' ) ) { + $d->Trailingcomma(1); + } + } + } $d; } @@ -411,7 +471,10 @@ sub emit_loud_diag { exit 70; } - my $msg = "\n$0: $args->{msg}"; + my $msg = "\n" . join( ': ', + ( $0 eq '-e' ? () : $0 ), + $args->{msg} + ); # when we die - we usually want to keep doing it $args->{emit_dups} = !!$args->{confess} @@ -577,10 +640,10 @@ 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 + # Recreate the logic of Try::Tiny, but without the crazy Sub::Name + # invocations and without support for finally() altogether + # ( yes, these days Try::Tiny is so "tiny" it shows *ON TOP* of most + # random profiles https://youtu.be/PYCbumw0Fis?t=1919 ) sub dbic_internal_try (&;@) { my $try_cref = shift; @@ -588,30 +651,30 @@ sub is_exception ($) { for my $arg (@_) { - if( ref($arg) eq 'Try::Tiny::Catch' ) { + croak 'dbic_internal_try() may not be followed by multiple dbic_internal_catch() blocks' + if $catch_cref; - croak 'dbic_internal_try() may not be followed by multiple catch() blocks' - if $catch_cref; + ($catch_cref = $$arg), next + if ref($arg) eq 'DBIx::Class::_Util::Catch'; - $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 - ); - } + croak( 'Mixing dbic_internal_try() with Try::Tiny::catch() is not supported' ) + if ref($arg) eq 'Try::Tiny::Catch'; + + croak( 'dbic_internal_try() does not support finally{}' ) + if ref($arg) eq 'Try::Tiny::Finally'; + + 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 { + my $saul_goodman = eval { $@ = $preexisting_exception; local $callstack_state->{in_internal_try} = 1 @@ -636,7 +699,7 @@ sub is_exception ($) { my $exception = $@; $@ = $preexisting_exception; - if ( $all_good ) { + if ( $saul_goodman ) { return $wantarray ? @ret : $ret[0] } elsif ( $catch_cref ) { @@ -648,7 +711,23 @@ sub is_exception ($) { return; } - sub in_internal_try { !! $callstack_state->{in_internal_try} } + sub dbic_internal_catch (&;@) { + + croak( 'Useless use of bare dbic_internal_catch()' ) + unless wantarray; + + croak( 'dbic_internal_catch() must receive exactly one argument at end of expression' ) + if @_ > 1; + + bless( + \( $_[0] ), + 'DBIx::Class::_Util::Catch' + ), + } + + sub in_internal_try () { + !! $callstack_state->{in_internal_try} + } } { @@ -719,11 +798,10 @@ sub modver_gt_or_eq ($$) { croak "Nonsensical minimum version supplied" 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)" - ); + my $ver_cache = do { + no strict 'refs'; + ${"${mod}::__DBIC_MODULE_VERSION_CHECKS__"} ||= {} + }; ! defined $ver_cache->{$ver} and @@ -732,6 +810,18 @@ sub modver_gt_or_eq ($$) { local $SIG{__WARN__} = sigwarn_silencer( qr/\Qisn't numeric in subroutine entry/ ) if SPURIOUS_VERSION_CHECK_WARNINGS; + # prevent captures by potential __WARN__ hooks or the like: + # there is nothing of value that can be happening here, and + # leaving a hook in-place can only serve to fail some test + local $SIG{__WARN__} if ( + ! SPURIOUS_VERSION_CHECK_WARNINGS + and + $SIG{__WARN__} + ); + + croak "$mod does not seem to provide a version (perhaps it never loaded)" + unless $mod->VERSION; + local $SIG{__DIE__} if $SIG{__DIE__}; local $@; eval { $mod->VERSION($ver) } ? 1 : 0; @@ -981,93 +1071,112 @@ sub mkdir_p ($) { } -{ - my $list_ctx_ok_stack_marker; - - sub fail_on_internal_wantarray () { - return if $list_ctx_ok_stack_marker; +sub fail_on_internal_call { + my $fr = [ CORE::caller(1) ]; - if (! defined wantarray) { - croak('fail_on_internal_wantarray() needs a tempvar to save the stack marker guard'); - } + die "\nMethod $fr->[3] is not marked with the 'DBIC_method_is_indirect_sugar' attribute\n\n" unless ( - my $cf = 1; - while ( ( (CORE::caller($cf+1))[3] || '' ) =~ / :: (?: + # unlikely but who knows... + ! @$fr - # these are public API parts that alter behavior on wantarray - search | search_related | slice | search_literal + or - | + # This is a weird-ass double-purpose method, only one branch of which is marked + # as an illegal indirect call + # Hence the 'indirect' attribute makes no sense + # FIXME - likely need to mark this in some other manner + $fr->[3] eq 'DBIx::Class::ResultSet::new' - # these are explicitly prefixed, since we only recognize them as valid - # escapes when they come from the guts of CDBICompat - CDBICompat .*? :: (?: search_where | retrieve_from_sql | retrieve_all ) + or - ) $/x ) { - $cf++; - } + # RsrcProxy stuff is special and not attr-annotated on purpose + # Yet it is marked (correctly) as fail_on_internal_call(), as DBIC + # itself should not call these methods as first-entry + $fr->[3] =~ /^DBIx::Class::ResultSourceProxy::[^:]+$/ - my ($fr, $want, $argdesc); - { - package DB; - $fr = [ CORE::caller($cf) ]; - $want = ( CORE::caller($cf-1) )[5]; - $argdesc = ref $DB::args[0] - ? DBIx::Class::_Util::refdesc($DB::args[0]) - : 'non ' - ; - }; + or - if ( - $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ - ) { - DBIx::Class::Exception->throw( sprintf ( - "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts", - $argdesc, @{$fr}[1,2] - ), 'with_stacktrace'); - } + # FIXME - there is likely a more fine-graned way to escape "foreign" + # callers, based on annotations... (albeit a slower one) + # For the time being just skip in a dumb way + $fr->[3] !~ /^DBIx::Class|^DBICx::|^DBICTest::/ - weaken( $list_ctx_ok_stack_marker = my $mark = [] ); + or - $mark; - } -} + grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { no strict 'refs'; attributes::get( \&{ $fr->[3] }) } + ); -sub fail_on_internal_call { - my ($fr, $argdesc); - { - package DB; - $fr = [ CORE::caller(1) ]; - $argdesc = ref $DB::args[0] - ? DBIx::Class::_Util::refdesc($DB::args[0]) - : ( $DB::args[0] . '' ) - ; - }; my @fr2; # need to make allowance for a proxy-yet-direct call - my $check_fr = ( - $fr->[0] eq 'DBIx::Class::ResultSourceProxy' - and - @fr2 = (CORE::caller(2)) - and + # or for an exception wrapper + $fr = \@fr2 if ( ( - ( $fr->[3] =~ /([^:])+$/ )[0] - eq - ( $fr2[3] =~ /([^:])+$/ )[0] + $fr->[3] eq '(eval)' + and + @fr2 = (CORE::caller(2)) ) - ) - ? \@fr2 - : $fr - ; + or + ( + $fr->[0] eq 'DBIx::Class::ResultSourceProxy' + and + @fr2 = (CORE::caller(2)) + and + ( + ( $fr->[3] =~ /([^:])+$/ )[0] + eq + ( $fr2[3] =~ /([^:])+$/ )[0] + ) + ) + ); + if ( - $argdesc + defined $fr->[0] + and + $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ and - $check_fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ + $fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there and - $check_fr->[1] !~ /\b(?:CDBICompat|ResultSetProxy)\b/ # no point touching there + # one step higher + @fr2 = CORE::caller(@fr2 ? 3 : 2) + and + # if the frame that called us is an indirect itself - nothing to see here + (! grep + { $_ eq 'DBIC_method_is_indirect_sugar' } + do { + no strict 'refs'; + attributes::get( \&{ $fr2[3] }) + } + ) + and + ( + $fr->[3] ne 'DBIx::Class::ResultSet::search' + or + # these are explicit wantarray-passthrough callsites for search() due to old silly API choice + $fr2[3] !~ /^DBIx::Class::Ordered::(?: _group_rs | (?: _ | next_ | previous_ )? siblings )/x + ) ) { + + my $argdesc; + + { + package DB; + + my @throwaway = caller( @fr2 ? 2 : 1 ); + + # screwing with $DB::args is rather volatile - be extra careful + no warnings 'uninitialized'; + + $argdesc = + ( not defined $DB::args[0] ) ? 'UNAVAILABLE' + : ( length ref $DB::args[0] ) ? DBIx::Class::_Util::refdesc($DB::args[0]) + : $DB::args[0] . '' + ; + }; + 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", $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do {