From: Peter Rabbitson <ribasushi@cpan.org>
Date: Tue, 15 Jul 2014 00:36:44 +0000 (+0200)
Subject: Consolidate bits and pieces under ::_Util::refdesc
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8433421f819142a4e4015993458b6df8f1583869;p=dbsrgits%2FDBIx-Class-Historic.git

Consolidate bits and pieces under ::_Util::refdesc

No functional changes
---

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index e281b66..612efa7 100644
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -57,7 +57,7 @@ use overload ();
 use base 'Exporter';
 our @EXPORT_OK = qw(
   sigwarn_silencer modver_gt_or_eq fail_on_internal_wantarray
-  refcount hrefaddr is_exception
+  refdesc refcount hrefaddr is_exception
   is_plain_value is_literal_value
   UNRESOLVABLE_CONDITION
 );
@@ -74,7 +74,19 @@ sub sigwarn_silencer ($) {
   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
 }
 
-sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr }
+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,7 +118,7 @@ sub is_exception ($) {
   if (defined $suberror) {
     if (length (my $class = blessed($e) )) {
       carp_unique( sprintf(
-        'External exception object %s=%s(%s) implements partial (broken) '
+        'External exception object %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 '
@@ -118,9 +130,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 ",
-        $class,
-        reftype $e,
-        hrefaddr $e,
+        refdesc $e,
         $class,
         'http://v.gd/DBIC_overload_tempfix/',
         $suberror,
@@ -226,11 +236,9 @@ sub is_plain_value ($) {
     if (
       (caller($cf))[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\tStacktrace starts",
+        refdesc($_[0]), (caller($cf))[1,2]
       ), 'with_stacktrace');
     }
 
diff --git a/t/lib/DBICTest/Util/LeakTracer.pm b/t/lib/DBICTest/Util/LeakTracer.pm
index 48ec21d..d0c29eb 100644
--- a/t/lib/DBICTest/Util/LeakTracer.pm
+++ b/t/lib/DBICTest/Util/LeakTracer.pm
@@ -5,7 +5,7 @@ use strict;
 
 use Carp;
 use Scalar::Util qw(isweak weaken blessed reftype);
-use DBIx::Class::_Util qw(refcount hrefaddr);
+use DBIx::Class::_Util qw(refcount hrefaddr refdesc);
 use DBIx::Class::Optional::Dependencies;
 use Data::Dumper::Concise;
 use DBICTest::Util 'stacktrace';
@@ -21,15 +21,6 @@ my $refs_traced = 0;
 my $leaks_found = 0;
 my %reg_of_regs;
 
-# so we don't trigger stringification
-sub _describe_ref {
-  sprintf '%s%s(%s)',
-    (defined blessed $_[0]) ? blessed($_[0]) . '=' : '',
-    reftype $_[0],
-    hrefaddr $_[0],
-  ;
-}
-
 sub populate_weakregistry {
   my ($weak_registry, $target, $note) = @_;
 
@@ -65,7 +56,7 @@ sub populate_weakregistry {
     $refs_traced++;
   }
 
-  my $desc = _describe_ref($target);
+  my $desc = refdesc $target;
   $weak_registry->{$refaddr}{slot_names}{$desc} = 1;
   if ($note) {
     $note =~ s/\s*\Q$desc\E\s*//g;
@@ -153,7 +144,7 @@ sub visit_refs {
         } scalar PadWalker::closed_over($r) ] }); # scalar due to RT#92269
       }
       1;
-    } or warn "Could not descend into @{[ _describe_ref($r) ]}: $@\n";
+    } or warn "Could not descend into @{[ refdesc $r ]}: $@\n";
   }
   $visited_cnt;
 }