X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=37dddfcb895efc858270890942da81e84249f851;hb=b34d93310401fd6f4fd68dc965b4aec592913eb1;hp=612efa7e5ddf1d0343f7391ea4d0e752775c516e;hpb=8433421f819142a4e4015993458b6df8f1583869;p=dbsrgits%2FDBIx-Class.git diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm index 612efa7..37dddfc 100644 --- a/lib/DBIx/Class/_Util.pm +++ b/lib/DBIx/Class/_Util.pm @@ -4,6 +4,37 @@ package # hide from PAUSE use warnings; use strict; +# Temporary - tempextlib +use namespace::clean; +BEGIN { + require Module::Runtime; + require File::Spec; + + # There can be only one of these, make sure we get the bundled part and + # *not* something off the site lib + for (qw( + DBIx::Class::SQLMaker + SQL::Abstract + SQL::Abstract::Test + )) { + if ($INC{Module::Runtime::module_notional_filename($_)}) { + die "\nUnable to continue - a part of the bundled templib contents " + . "was already loaded (likely an older version from CPAN). " + . "Make sure that @{[ __PACKAGE__ ]} is loaded before $_\n\n" + ; + } + } + + our ($HERE) = File::Spec->rel2abs( + File::Spec->catdir( (File::Spec->splitpath(__FILE__))[1], '_TempExtlib' ) + ) =~ /^(.*)$/; # screw you, taint mode + + die "TempExtlib $HERE does not seem to exist - perhaps you need to run `perl Makefile.PL` in the DBIC checkout?\n" + unless -d $HERE; + + unshift @INC, $HERE; +} + use constant SPURIOUS_VERSION_CHECK_WARNINGS => ($] < 5.010 ? 1 : 0); BEGIN { @@ -17,6 +48,8 @@ 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/ @@ -30,6 +63,8 @@ BEGIN { 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, @@ -52,13 +87,24 @@ use DBIx::Class::Carp '^DBIx::Class|^DBICTest'; use Carp 'croak'; use Scalar::Util qw(weaken blessed reftype); use List::Util qw(first); -use overload (); + +# 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 + sigwarn_silencer modver_gt_or_eq + fail_on_internal_wantarray fail_on_internal_call refdesc refcount hrefaddr is_exception - is_plain_value is_literal_value + quote_sub qsub perlstring serialize UNRESOLVABLE_CONDITION ); @@ -74,6 +120,8 @@ sub sigwarn_silencer ($) { return sub { &$orig_sig_warn unless $_[0] =~ $pattern }; } +sub perlstring ($) { q{"}. quotemeta( shift ). q{"} }; + sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr||0 } sub refdesc ($) { @@ -97,6 +145,12 @@ sub refcount ($) { B::svref_2object($_[0])->REFCNT; } +sub serialize ($) { + require Storable; + local $Storable::canonical = 1; + Storable::nfreeze($_[0]); +} + sub is_exception ($) { my $e = $_[0]; @@ -118,8 +172,8 @@ sub is_exception ($) { if (defined $suberror) { if (length (my $class = blessed($e) )) { carp_unique( sprintf( - 'External exception object %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 ' @@ -130,7 +184,7 @@ sub is_exception ($) { . '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 ", - refdesc $e, + $class, $class, 'http://v.gd/DBIC_overload_tempfix/', $suberror, @@ -168,49 +222,10 @@ sub modver_gt_or_eq ($$) { eval { $mod->VERSION($ver) } ? 1 : 0; } -sub is_literal_value ($) { - ( - ref $_[0] eq 'SCALAR' - or - ( ref $_[0] eq 'REF' and ref ${$_[0]} eq 'ARRAY' ) - ) ? 1 : 0; -} - -# FIXME XSify - this can be done so much more efficiently -sub is_plain_value ($) { - no strict 'refs'; - ( - # plain scalar - (! length ref $_[0]) - or - ( - blessed $_[0] - and - # deliberately not using Devel::OverloadInfo - the checks we are - # intersted in are much more limited than the fullblown thing, and - # this is a relatively hot piece of code - ( - # FIXME - DBI needs fixing to stringify regardless of DBD - # - # either has stringification which DBI SHOULD prefer out of the box - #first { *{$_ . '::(""'}{CODE} } @{ mro::get_linear_isa( ref $_[0] ) } - overload::Method($_[0], '""') - or - # has nummification and fallback is *not* disabled - ( - $_[1] = first { *{"${_}::(0+"}{CODE} } @{ mro::get_linear_isa( ref $_[0] ) } - and - ( ! defined ${"$_[1]::()"} or ${"$_[1]::()"} ) - ) - ) - ) - ) ? 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) { @@ -233,12 +248,23 @@ sub is_plain_value ($) { $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::)/ ) { DBIx::Class::Exception->throw( sprintf ( - "Improper use of %s instance in list context at %s line %d\n\n\tStacktrace starts", - refdesc($_[0]), (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'); } @@ -248,4 +274,33 @@ sub is_plain_value ($) { } } +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;