X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=83bca471c24b193e2f8806f00d658a35a0786041;hb=8d73fcd44e0441f0252744be32bada6816c5ff6b;hp=e281b66807f4d3674c5ae48c0d9c7bdc3f0d9464;hpb=facd0e8e687648e52f29df73d62d9c993b9b19d1;p=dbsrgits%2FDBIx-Class.git

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index e281b66..83bca47 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -17,6 +17,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 +32,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 +56,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 &quote_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
-  is_plain_value is_literal_value
+  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
 );
 
@@ -74,7 +89,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];
@@ -106,8 +135,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 '
@@ -119,8 +148,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,
@@ -158,49 +185,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) {
@@ -223,14 +211,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::)/
     ) {
-      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');
     }
 
@@ -240,4 +237,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;