X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FDBIx%2FClass%2F_Util.pm;h=7cf6a5272a7ac89328d88e2507e330b13563765c;hb=6cfb1d2f28554c9d8943275fee3774a5f4d448d4;hp=cf7443ffb66c2ebff96a256cdffc0d0307d615bb;hpb=00882d2c977e56a42654e8c5bb3cd02fde7921f5;p=dbsrgits%2FDBIx-Class-Historic.git

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index cf7443f..7cf6a52 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -23,14 +23,8 @@ 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) ),
 
     ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
 
@@ -49,13 +43,23 @@ 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);
+use overload ();
 
 use base 'Exporter';
-our @EXPORT_OK = qw(sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray);
+our @EXPORT_OK = qw(
+  sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray
+  refcount hrefaddr is_exception
+  is_plain_value is_literal_value
+);
 
-sub sigwarn_silencer {
+sub sigwarn_silencer ($) {
   my $pattern = shift;
 
   croak "Expecting a regexp" if ref $pattern ne 'Regexp';
@@ -65,7 +69,72 @@ sub sigwarn_silencer {
   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
 }
 
-sub modver_gt_or_eq {
+sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr }
+
+sub refcount ($) {
+  croak "Expecting a reference" if ! length ref $_[0];
+
+  require B;
+  # No tempvars - must operate on $_[0], otherwise the pad
+  # will count as an extra ref
+  B::svref_2object($_[0])->REFCNT;
+}
+
+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 object %s=%s(%s) implements partial (broken) '
+      . 'overloading preventing it 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,
+        reftype $e,
+        hrefaddr $e,
+        $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"
@@ -77,10 +146,50 @@ 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 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
+      (
+        # either has stringification which DBI prefers 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;
 
@@ -113,8 +222,8 @@ sub modver_gt_or_eq {
       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(%s) instance in list context at %s line %d\n\n\tStacktrace starts",
+        ref($obj), hrefaddr($obj), (caller($cf))[1,2]
       ), 'with_stacktrace');
     }