X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=384d3e015cdf3fe086406537a6b0539ca753a3e8;hb=7f9a3f70074c5d4eb4e8260648f055b7556a7a4f;hp=518457cd357dc921ca72f4264c7a2afb81d45391;hpb=56270bba4fb06051ea5262d99f858920c796562e;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 518457c..384d3e0 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -23,17 +23,15 @@ BEGIN { DBICTEST => eval { DBICTest::RunMode->is_author } ? 1 : 0, # During 5.13 dev cycle HELEMs started to leak on copy - PEEPEENESS => - # request for all tests would force "non-leaky" illusion and vice-versa - defined $ENV{DBICTEST_ALL_LEAKS} ? !$ENV{DBICTEST_ALL_LEAKS} - # otherwise confess that this perl is busted ONLY on smokers - : eval { DBICTest::RunMode->is_smoker } && ($] >= 5.013005 and $] <= 5.013006) ? 1 - # otherwise we are good - : 0 - , + # 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, + IV_SIZE => $Config{ivsize}, OS_NAME => $^O, @@ -55,9 +53,29 @@ use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; use Carp 'croak'; use Scalar::Util qw(weaken blessed reftype); +use List::Util qw(first); + +# DO NOT edit away without talking to riba first, he will just put it back +# BEGIN pre-Moo2 import block +BEGIN { + my $initial_fatal_bits = (${^WARNING_BITS}||'') & $warnings::DeadBits{all}; + local $ENV{PERL_STRICTURES_EXTRA} = 0; + require Sub::Quote; Sub::Quote->import('quote_sub'); + ${^WARNING_BITS} &= ( $initial_fatal_bits | ~ $warnings::DeadBits{all} ); +} +sub qsub ($) { goto "e_sub } # no point depping on new Moo just for this +# END pre-Moo2 import block use base 'Exporter'; -our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray refcount hrefaddr is_exception); +our @EXPORT_OK = qw( + sigwarn_silencer modver_gt_or_eq + fail_on_internal_wantarray fail_on_internal_call + refdesc refcount hrefaddr is_exception + quote_sub qsub perlstring + UNRESOLVABLE_CONDITION +); + +use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; sub sigwarn_silencer ($) { my $pattern = shift; @@ -69,7 +87,21 @@ sub sigwarn_silencer ($) { return sub { &$orig_sig_warn unless $_[0] =~ $pattern }; } -sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr } +sub perlstring ($) { q{"}. quotemeta( shift ). q{"} }; + +sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr||0 } + +sub refdesc ($) { + croak "Expecting a reference" if ! length ref $_[0]; + + # be careful not to trigger stringification, + # reuse @_ as a scratch-pad + sprintf '%s%s(0x%x)', + ( defined( $_[1] = blessed $_[0]) ? "$_[1]=" : '' ), + reftype $_[0], + Scalar::Util::refaddr($_[0]), + ; +} sub refcount ($) { croak "Expecting a reference" if ! length ref $_[0]; @@ -101,8 +133,8 @@ sub is_exception ($) { if (defined $suberror) { if (length (my $class = blessed($e) )) { carp_unique( sprintf( - 'External exception object %s=%s(%s) implements partial (broken) ' - . 'overloading preventing it from being used in simple ($x eq $y) ' + 'External exception class %s implements partial (broken) overloading ' + . 'preventing its instances from being used in simple ($x eq $y) ' . 'comparisons. Given Perl\'s "globally cooperative" exception ' . 'handling this type of brokenness is extremely dangerous on ' . 'exception objects, as it may (and often does) result in silent ' @@ -114,8 +146,6 @@ sub is_exception ($) { . 'is saner application-wide. What follows is the actual error text ' . "as generated by Perl itself:\n\n%s\n ", $class, - reftype $e, - hrefaddr $e, $class, 'http://v.gd/DBIC_overload_tempfix/', $suberror, @@ -156,7 +186,7 @@ sub modver_gt_or_eq ($$) { { my $list_ctx_ok_stack_marker; - sub fail_on_internal_wantarray { + sub fail_on_internal_wantarray () { return if $list_ctx_ok_stack_marker; if (! defined wantarray) { @@ -179,14 +209,23 @@ sub modver_gt_or_eq ($$) { $cf++; } + my ($fr, $want, $argdesc); + { + package DB; + $fr = [ caller($cf) ]; + $want = ( caller($cf-1) )[5]; + $argdesc = ref $DB::args[0] + ? DBIx::Class::_Util::refdesc($DB::args[0]) + : 'non ' + ; + }; + if ( - (caller($cf))[0] =~ /^(?:DBIx::Class|DBICx::)/ + $want and $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ ) { - my $obj = shift; - DBIx::Class::Exception->throw( sprintf ( - "Improper use of %s(%s) instance in list context at %s line %d\n\n\tStacktrace starts", - ref($obj), hrefaddr($obj), (caller($cf))[1,2] + "Improper use of %s instance in list context at %s line %d\n\n Stacktrace starts", + $argdesc, @{$fr}[1,2] ), 'with_stacktrace'); } @@ -196,4 +235,33 @@ sub modver_gt_or_eq ($$) { } } +sub fail_on_internal_call { + my ($fr, $argdesc); + { + package DB; + $fr = [ caller(1) ]; + $argdesc = ref $DB::args[0] + ? DBIx::Class::_Util::refdesc($DB::args[0]) + : undef + ; + }; + + if ( + $argdesc + and + $fr->[0] =~ /^(?:DBIx::Class|DBICx::)/ + and + $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", + $fr->[3], $argdesc, @{$fr}[1,2], ( $fr->[6] || do { + require B::Deparse; + no strict 'refs'; + B::Deparse->new->coderef2text(\&{$fr->[3]}) + }), + ), 'with_stacktrace'); + } +} + 1;