Switch DBIC::Storage::Statistics to Moo (for trial purposes)

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

diff --git a/lib/DBIx/Class/_Util.pm b/lib/DBIx/Class/_Util.pm
index 6b8f87c..ad438e7 100644 (file)
--- a/lib/DBIx/Class/_Util.pm
+++ b/lib/DBIx/Class/_Util.pm
@@ -23,14 +23,10 @@ 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) ),
+
+    SHUFFLE_UNORDERED_RESULTSETS => $ENV{DBIC_SHUFFLE_UNORDERED_RESULTSETS} ? 1 : 0,
 
     ASSERT_NO_INTERNAL_WANTARRAY => $ENV{DBIC_ASSERT_NO_INTERNAL_WANTARRAY} ? 1 : 0,
 
@@ -54,12 +50,18 @@ BEGIN {
 use DBIx::Class::Carp '^DBIx::Class|^DBICTest';
 
 use Carp 'croak';
-use Scalar::Util qw(refaddr weaken blessed reftype);
+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 refcount is_exception);
+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';
@@ -69,7 +71,9 @@ sub sigwarn_silencer {
   return sub { &$orig_sig_warn unless $_[0] =~ $pattern };
 }
 
-sub refcount {
+sub hrefaddr ($) { sprintf '0x%x', &Scalar::Util::refaddr }
+
+sub refcount ($) {
   croak "Expecting a reference" if ! length ref $_[0];
 
   require B;
@@ -81,6 +85,12 @@ sub refcount {
 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 $@;
@@ -93,7 +103,7 @@ sub is_exception ($) {
   if (defined $suberror) {
     if (length (my $class = blessed($e) )) {
       carp_unique( sprintf(
-        'External exception object %s=%s(0x%x) implements partial (broken) '
+        '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 '
@@ -107,7 +117,7 @@ sub is_exception ($) {
       . "as generated by Perl itself:\n\n%s\n ",
         $class,
         reftype $e,
-        refaddr $e,
+        hrefaddr $e,
         $class,
         'http://v.gd/DBIC_overload_tempfix/',
         $suberror,
@@ -126,7 +136,7 @@ sub is_exception ($) {
   return $not_blank;
 }
 
-sub modver_gt_or_eq {
+sub modver_gt_or_eq ($$) {
   my ($mod, $ver) = @_;
 
   croak "Nonsensical module name supplied"
@@ -138,10 +148,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;
 
@@ -174,8 +224,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');
     }