Consolidate bits and pieces under ::_Util::refdesc

[dbsrgits/DBIx-Class.git] / lib / DBIx / Class / _Util.pm

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index e281b66..612efa7 100644 (file)
--- 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');
     }