X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=be34bc6de243f50148b21026ca7ae7d1831b6974;hb=9a3d73e9f21ef4ebd892eb8186234c1d248dd035;hp=0afe2eabfd0f658efd0424464bdb96d22312c9af;hpb=dac7972a0974db384637b7a8d9a661b08853b3cf;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 0afe2ea..be34bc6 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -17,23 +17,25 @@ BEGIN { # but of course BROKEN_FORK => ($^O eq 'MSWin32') ? 1 : 0, + BROKEN_GOTO => ($] < '5.008003') ? 1 : 0, + HAS_ITHREADS => $Config{useithreads} ? 1 : 0, # ::Runmode would only be loaded by DBICTest, which in turn implies t/ 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, + + STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE => $ENV{DBIC_STRESSTEST_UTF8_UPGRADE_GENERATED_COLLAPSER_SOURCE} ? 1 : 0, + IV_SIZE => $Config{ivsize}, OS_NAME => $^O, @@ -49,13 +51,43 @@ BEGIN { } } -use Carp; -use Scalar::Util qw(refaddr weaken); +# FIXME - this is not supposed to be here +# Carp::Skip to the rescue soon +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; + # load all of these now, so that lazy-loading does not escape + # the current PERL_STRICTURES_EXTRA setting + require Sub::Quote; + require Sub::Defer; + + 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); +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 + quote_sub qsub perlstring serialize + UNRESOLVABLE_CONDITION +); -sub sigwarn_silencer { +use constant UNRESOLVABLE_CONDITION => \ '1 = 0'; + +sub sigwarn_silencer ($) { my $pattern = shift; croak "Expecting a regexp" if ref $pattern ne 'Regexp'; @@ -65,7 +97,23 @@ sub sigwarn_silencer { return sub { &$orig_sig_warn unless $_[0] =~ $pattern }; } -sub refcount { +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]; require B; @@ -74,7 +122,65 @@ sub refcount { B::svref_2object($_[0])->REFCNT; } -sub modver_gt_or_eq { +sub serialize ($) { + require Storable; + local $Storable::canonical = 1; + Storable::nfreeze($_[0]); +} + +sub is_exception ($) { + my $e = $_[0]; + + # 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 + # the time being + return 0 unless defined $e; + + my ($not_blank, $suberror); + { + local $@; + eval { + $not_blank = ($e ne '') ? 1 : 0; + 1; + } or $suberror = $@; + } + + if (defined $suberror) { + if (length (my $class = blessed($e) )) { + carp_unique( sprintf( + '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 ' + . '"exception substitution". DBIx::Class tries to work around this ' + . 'as much as possible, but other parts of your software stack may ' + . 'not be even aware of this. Please submit a bugreport against the ' + . 'distribution containing %s and in the meantime apply a fix similar ' + . 'to the one shown at %s, in order to ensure your exception handling ' + . 'is saner application-wide. What follows is the actual error text ' + . "as generated by Perl itself:\n\n%s\n ", + $class, + $class, + 'http://v.gd/DBIC_overload_tempfix/', + $suberror, + )); + + # workaround, keeps spice flowing + $not_blank = ("$e" ne '') ? 1 : 0; + } + else { + # not blessed yet failed the 'ne'... this makes 0 sense... + # just throw further + die $suberror + } + } + + return $not_blank; +} + +sub modver_gt_or_eq ($$) { my ($mod, $ver) = @_; croak "Nonsensical module name supplied" @@ -86,14 +192,30 @@ sub modver_gt_or_eq { 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 $@; eval { $mod->VERSION($ver) } ? 1 : 0; } +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\.\_]/; + + return ( + modver_gt_or_eq($mod, $v_ge) + and + ! modver_gt_or_eq($mod, $v_lt) + ) ? 1 : 0; +} + { 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) { @@ -116,14 +238,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(0x%x) instance in list context at %s line %d\n\n\tStacktrace starts", - ref($obj), refaddr($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'); } @@ -133,4 +264,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;